src/Gargantext/API/Ngrams/Types.hs

   1 {-|
   2 Module      : Gargantext.API.Ngrams.Types
   3 Description : Ngrams List Types
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9 -}
  10
  11 {-# LANGUAGE ConstraintKinds   #-}
  12 {-# LANGUAGE ScopedTypeVariables #-}
  13 {-# LANGUAGE TemplateHaskell   #-}
  14 {-# LANGUAGE TypeOperators     #-}
  15 {-# LANGUAGE TypeFamilies      #-}
  16 {-# OPTIONS -fno-warn-orphans #-}
  17
  18 module Gargantext.API.Ngrams.Types where
  19
  20 import Codec.Serialise (Serialise())
  21 import Control.Category ((>>>))
  22 import Control.DeepSeq (NFData)
  23 import Control.Lens (makeLenses, makePrisms, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~))
  24 import Control.Monad.State
  25 import Data.Aeson hiding ((.=))
  26 import Data.Aeson.TH (deriveJSON)
  27 import Data.Either (Either(..))
  28 import Data.Foldable
  29 import Data.Hashable (Hashable)
  30 import Data.Map.Strict (Map)
  31 import Data.Maybe (fromMaybe)
  32 import Data.Monoid
  33 import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, MaybePatch(Mod), unMod, old, new)
  34 import Data.Set (Set)
  35 import Data.String (IsString, fromString)
  36 import Data.Swagger hiding (version, patch)
  37 import Data.Text (Text, pack, strip)
  38 import Data.Validity
  39 import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
  40 import Database.PostgreSQL.Simple.ToField (ToField, toJSONField, toField)
  41 import GHC.Generics (Generic)
  42 import Gargantext.Core.Text (size)
  43 import Gargantext.Core.Types (ListType(..), ListId, NodeId, TODO)
  44 import Gargantext.Core.Types.Query (Limit, Offset, MaxSize, MinSize)
  45 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger, wellNamedSchema)
  46 import Gargantext.Database.Admin.Types.Node (ContextId)
  47 import Gargantext.Database.Prelude (fromField', HasConnectionPool, HasConfig, CmdM')
  48 import Gargantext.Prelude
  49 import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
  50 import Protolude (maybeToEither)
  51 import Servant hiding (Patch)
  52 import Servant.Job.Utils (jsonOptions)
  53 -- import System.FileLock (FileLock)
  54 import Test.QuickCheck (elements, frequency)
  55 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  56 import qualified Data.HashMap.Strict.InsOrd             as InsOrdHashMap
  57 import qualified Data.Map.Strict                        as Map
  58 import qualified Data.Map.Strict.Patch                  as PM
  59 import qualified Data.Set                               as Set
  60 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
  61
  62 ------------------------------------------------------------------------
  63
  64 type QueryParamR = QueryParam' '[Required, Strict]
  65
  66 ------------------------------------------------------------------------
  67 --data FacetFormat = Table | Chart
  68 data TabType   = Docs   | Trash   | MoreFav | MoreTrash
  69                | Terms  | Sources | Authors | Institutes
  70                | Contacts
  71   deriving (Bounded, Enum, Eq, Generic, Ord, Show)
  72
  73
  74 instance Hashable TabType
  75
  76 instance FromHttpApiData TabType where
  77     parseUrlPiece "Docs"       = pure Docs
  78     parseUrlPiece "Trash"      = pure Trash
  79     parseUrlPiece "MoreFav"    = pure MoreFav
  80     parseUrlPiece "MoreTrash"  = pure MoreTrash
  81
  82     parseUrlPiece "Terms"      = pure Terms
  83     parseUrlPiece "Sources"    = pure Sources
  84     parseUrlPiece "Institutes" = pure Institutes
  85     parseUrlPiece "Authors"    = pure Authors
  86
  87     parseUrlPiece "Contacts"   = pure Contacts
  88
  89     parseUrlPiece _            = Left "Unexpected value of TabType"
  90 instance ToHttpApiData TabType where
  91     toUrlPiece = pack . show
  92 instance ToParamSchema TabType
  93 instance ToJSON        TabType
  94 instance FromJSON      TabType
  95 instance ToSchema      TabType
  96 instance Arbitrary     TabType where
  97   arbitrary = elements [minBound .. maxBound]
  98 instance FromJSONKey TabType where
  99   fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
 100 instance ToJSONKey TabType where
 101   toJSONKey = genericToJSONKey defaultJSONKeyOptions
 102
 103 newtype MSet a = MSet (Map a ())
 104   deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
 105
 106 instance ToJSON a => ToJSON (MSet a) where
 107   toJSON     (MSet m) = toJSON     (Map.keys m)
 108   toEncoding (MSet m) = toEncoding (Map.keys m)
 109
 110 mSetFromSet :: Set a -> MSet a
 111 mSetFromSet = MSet . Map.fromSet (const ())
 112
 113 mSetFromList :: Ord a => [a] -> MSet a
 114 mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
 115
 116 -- mSetToSet :: Ord a => MSet a -> Set a
 117 -- mSetToSet (MSet a) = Set.fromList ( Map.keys a)
 118 mSetToSet :: Ord a => MSet a -> Set a
 119 mSetToSet = Set.fromList . mSetToList
 120
 121 mSetToList :: MSet a -> [a]
 122 mSetToList (MSet a) = Map.keys a
 123
 124 instance Foldable MSet where
 125   foldMap f (MSet m) = Map.foldMapWithKey (\k _ -> f k) m
 126
 127 instance (Ord a, FromJSON a) => FromJSON (MSet a) where
 128   parseJSON = fmap mSetFromList . parseJSON
 129
 130 instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
 131   -- TODO
 132   declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
 133
 134 ------------------------------------------------------------------------
 135 newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text }
 136   deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable, NFData, FromField, ToField)
 137 instance IsHashable NgramsTerm where
 138   hash (NgramsTerm t) = hash t
 139 instance Monoid NgramsTerm where
 140   mempty = NgramsTerm ""
 141 instance FromJSONKey NgramsTerm where
 142   fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t
 143 instance IsString NgramsTerm where
 144   fromString s = NgramsTerm $ pack s
 145
 146
 147 data RootParent = RootParent
 148   { _rp_root   :: NgramsTerm
 149   , _rp_parent :: NgramsTerm
 150   }
 151   deriving (Ord, Eq, Show, Generic)
 152
 153 deriveJSON (unPrefix "_rp_") ''RootParent
 154 makeLenses ''RootParent
 155
 156 data NgramsRepoElement = NgramsRepoElement
 157   { _nre_size        :: !Int
 158   , _nre_list        :: !ListType
 159   , _nre_root        :: !(Maybe NgramsTerm)
 160   , _nre_parent      :: !(Maybe NgramsTerm)
 161   , _nre_children    :: !(MSet NgramsTerm)
 162   }
 163   deriving (Ord, Eq, Show, Generic)
 164 deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
 165 -- TODO
 166 -- if ngrams & not size => size
 167 -- drop occurrences
 168 makeLenses ''NgramsRepoElement
 169 instance ToSchema NgramsRepoElement where
 170   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
 171 instance Serialise NgramsRepoElement
 172 instance FromField NgramsRepoElement where
 173   fromField = fromJSONField
 174 instance ToField NgramsRepoElement where
 175   toField = toJSONField
 176
 177 instance Serialise (MSet NgramsTerm)
 178
 179 data NgramsElement =
 180      NgramsElement { _ne_ngrams      :: NgramsTerm
 181                    , _ne_size        :: Int
 182                    , _ne_list        :: ListType
 183                    , _ne_occurrences :: Set ContextId
 184                    , _ne_root        :: Maybe NgramsTerm
 185                    , _ne_parent      :: Maybe NgramsTerm
 186                    , _ne_children    :: MSet  NgramsTerm
 187                    }
 188       deriving (Ord, Eq, Show, Generic)
 189
 190 deriveJSON (unPrefix "_ne_") ''NgramsElement
 191 makeLenses ''NgramsElement
 192
 193 mkNgramsElement :: NgramsTerm
 194                 -> ListType
 195                 -> Maybe RootParent
 196                 -> MSet NgramsTerm
 197                 -> NgramsElement
 198 mkNgramsElement ngrams list rp children =
 199   NgramsElement ngrams (size (unNgramsTerm ngrams)) list mempty (_rp_root <$> rp) (_rp_parent <$> rp) children
 200
 201 newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
 202 newNgramsElement mayList ngrams =
 203   mkNgramsElement ngrams (fromMaybe MapTerm mayList) Nothing mempty
 204
 205 instance ToSchema NgramsElement where
 206   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
 207 instance Arbitrary NgramsElement where
 208   arbitrary = elements [newNgramsElement Nothing "sport"]
 209
 210
 211 ------------------------------------------------------------------------
 212 newtype NgramsTable = NgramsTable [NgramsElement]
 213   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 214
 215 -- type NgramsList = NgramsTable
 216
 217 makePrisms ''NgramsTable
 218
 219 -- | Question: why these repetition of Type in this instance
 220 -- may you document it please ?
 221 instance Each NgramsTable NgramsTable NgramsElement NgramsElement where
 222   each = _NgramsTable . each
 223
 224 -- TODO discuss
 225 -- | TODO Check N and Weight
 226 {-
 227 toNgramsElement :: [NgramsTableData] -> [NgramsElement]
 228 toNgramsElement ns = map toNgramsElement' ns
 229     where
 230       toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
 231         where
 232           p' = case p of
 233                  Nothing -> Nothing
 234                  Just x  -> lookup x mapParent
 235           c' = maybe mempty identity $ lookup t mapChildren
 236           lt' = maybe (panic "API.Ngrams: listypeId") identity lt
 237
 238       mapParent :: Map Int Text
 239       mapParent   = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
 240
 241       mapChildren :: Map Text (Set Text)
 242       mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
 243                   $ Map.fromListWith (<>)
 244                   $ map (first fromJust)
 245                   $ filter (isJust . fst)
 246                   $ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
 247 -}
 248
 249 mockTable :: NgramsTable
 250 mockTable = NgramsTable
 251   [ mkNgramsElement "animal"  MapTerm        Nothing       (mSetFromList ["dog", "cat"])
 252   , mkNgramsElement "cat"     MapTerm       (rp "animal")  mempty
 253   , mkNgramsElement "cats"    StopTerm       Nothing       mempty
 254   , mkNgramsElement "dog"     MapTerm       (rp "animal")  (mSetFromList ["dogs"])
 255   , mkNgramsElement "dogs"    StopTerm      (rp "dog")     mempty
 256   , mkNgramsElement "fox"     MapTerm        Nothing       mempty
 257   , mkNgramsElement "object"  CandidateTerm  Nothing       mempty
 258   , mkNgramsElement "nothing" StopTerm       Nothing       mempty
 259   , mkNgramsElement "organic" MapTerm        Nothing       (mSetFromList ["flower"])
 260   , mkNgramsElement "flower"  MapTerm       (rp "organic") mempty
 261   , mkNgramsElement "moon"    CandidateTerm  Nothing       mempty
 262   , mkNgramsElement "sky"     StopTerm       Nothing       mempty
 263   ]
 264   where
 265     rp n = Just $ RootParent n n
 266
 267 instance Arbitrary NgramsTable where
 268   arbitrary = pure mockTable
 269
 270 instance ToSchema NgramsTable
 271
 272 ------------------------------------------------------------------------
 273 -- Searching in a Ngram Table
 274
 275 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
 276              deriving (Generic, Enum, Bounded, Read, Show)
 277
 278 instance FromHttpApiData OrderBy
 279   where
 280     parseUrlPiece "TermAsc"   = pure TermAsc
 281     parseUrlPiece "TermDesc"  = pure TermDesc
 282     parseUrlPiece "ScoreAsc"  = pure ScoreAsc
 283     parseUrlPiece "ScoreDesc" = pure ScoreDesc
 284     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 285
 286 instance ToHttpApiData OrderBy where
 287   toUrlPiece = pack . show
 288
 289 instance ToParamSchema OrderBy
 290 instance FromJSON  OrderBy
 291 instance ToJSON    OrderBy
 292 instance ToSchema  OrderBy
 293 instance Arbitrary OrderBy
 294   where
 295     arbitrary = elements [minBound..maxBound]
 296
 297
 298 -- | A query on a 'NgramsTable'.
 299 data NgramsSearchQuery = NgramsSearchQuery
 300   { _nsq_limit       :: !Limit
 301   , _nsq_offset      :: !(Maybe Offset)
 302   , _nsq_listType    :: !(Maybe ListType)
 303   , _nsq_minSize     :: !(Maybe MinSize)
 304   , _nsq_maxSize     :: !(Maybe MaxSize)
 305   , _nsq_orderBy     :: !(Maybe OrderBy)
 306   , _nsq_searchQuery :: !(NgramsTerm -> Bool)
 307   }
 308
 309 ------------------------------------------------------------------------
 310 type NgramsTableMap = Map NgramsTerm NgramsRepoElement
 311 ------------------------------------------------------------------------
 312 -- On the Client side:
 313 --data Action = InGroup     NgramsId NgramsId
 314 --            | OutGroup    NgramsId NgramsId
 315 --            | SetListType NgramsId ListType
 316
 317 data PatchSet a = PatchSet
 318   { _rem :: Set a
 319   , _add :: Set a
 320   }
 321   deriving (Eq, Ord, Show, Generic)
 322
 323 makeLenses ''PatchSet
 324 makePrisms ''PatchSet
 325
 326 instance ToJSON a => ToJSON (PatchSet a) where
 327   toJSON     = genericToJSON     $ unPrefix "_"
 328   toEncoding = genericToEncoding $ unPrefix "_"
 329
 330 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
 331   parseJSON = genericParseJSON $ unPrefix "_"
 332
 333 {-
 334 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 335   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 336
 337 type instance Patched (PatchSet a) = Set a
 338
 339 type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
 340 type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
 341
 342 instance Ord a => Semigroup (PatchSet a) where
 343   p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem
 344                     , _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add
 345                     } -- TODO Review
 346
 347 instance Ord a => Monoid (PatchSet a) where
 348   mempty = PatchSet mempty mempty
 349
 350 instance Ord a => Group (PatchSet a) where
 351   invert (PatchSet r a) = PatchSet a r
 352
 353 instance Ord a => Composable (PatchSet a) where
 354   composable _ _ = undefined
 355
 356 instance Ord a => Action (PatchSet a) (Set a) where
 357   act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
 358
 359 instance Applicable (PatchSet a) (Set a) where
 360   applicable _ _ = mempty
 361
 362 instance Ord a => Validity (PatchSet a) where
 363   validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
 364
 365 instance Ord a => Transformable (PatchSet a) where
 366   transformable = undefined
 367
 368   conflicts _p _q = undefined
 369
 370   transformWith conflict p q = undefined conflict p q
 371
 372 instance ToSchema a => ToSchema (PatchSet a)
 373 -}
 374
 375 type AddRem = Replace (Maybe ())
 376
 377 instance Serialise AddRem
 378
 379 remPatch, addPatch :: AddRem
 380 remPatch = replace (Just ()) Nothing
 381 addPatch = replace Nothing (Just ())
 382
 383 isRem :: Replace (Maybe ()) -> Bool
 384 isRem = (== remPatch)
 385
 386 type PatchMap = PM.PatchMap
 387
 388 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
 389   deriving (Eq, Show, Generic, Validity, Semigroup, Monoid, Group,
 390             Transformable, Composable)
 391
 392 unPatchMSet :: PatchMSet a -> PatchMap a AddRem
 393 unPatchMSet (PatchMSet a) = a
 394
 395 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
 396 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
 397
 398 instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
 399 instance (Serialise a, Ord a) => Serialise (PatchMSet a)
 400
 401 -- TODO this breaks module abstraction
 402 makePrisms ''PM.PatchMap
 403
 404 makePrisms ''PatchMSet
 405
 406 _PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
 407 _PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
 408   where
 409     f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
 410     f = Map.partition isRem >>> both %~ Map.keysSet
 411
 412     g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
 413     g (rems, adds) = Map.fromSet (const remPatch) rems
 414                   <> Map.fromSet (const addPatch) adds
 415
 416 instance Ord a => Action (PatchMSet a) (MSet a) where
 417   act (PatchMSet p) (MSet m) = MSet $ act p m
 418
 419 instance Ord a => Applicable (PatchMSet a) (MSet a) where
 420   applicable (PatchMSet p) (MSet m) = applicable p m
 421
 422 instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
 423   toJSON     = toJSON . view _PatchMSetIso
 424   toEncoding = toEncoding . view _PatchMSetIso
 425
 426 instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
 427   parseJSON = fmap (_PatchMSetIso #) . parseJSON
 428
 429 instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
 430   arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
 431
 432 instance ToSchema a => ToSchema (PatchMSet a) where
 433   -- TODO
 434   declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
 435
 436 type instance Patched (PatchMSet a) = MSet a
 437
 438 instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
 439   arbitrary = uncurry replace <$> arbitrary
 440     -- If they happen to be equal then the patch is Keep.
 441
 442 instance ToSchema a => ToSchema (Replace a) where
 443   declareNamedSchema (_ :: Proxy (Replace a)) = do
 444     -- TODO Keep constructor is not supported here.
 445     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 446     return $ NamedSchema (Just "Replace") $ mempty
 447             & type_ ?~ SwaggerObject
 448             & properties .~
 449                 InsOrdHashMap.fromList
 450                 [ ("old", aSchema)
 451                 , ("new", aSchema)
 452                 ]
 453             & required .~ [ "old", "new" ]
 454
 455 data NgramsPatch
 456    = NgramsPatch { _patch_children :: !(PatchMSet NgramsTerm)
 457                  , _patch_list     :: !(Replace ListType)   -- TODO Map UserId ListType
 458                  }
 459    | NgramsReplace { _patch_old :: !(Maybe NgramsRepoElement)
 460                    , _patch_new :: !(Maybe NgramsRepoElement)
 461                    }
 462       deriving (Eq, Show, Generic)
 463
 464 -- The JSON encoding is untagged, this is OK since the field names are disjoints and thus the encoding is unambiguous.
 465 -- TODO: the empty object should be accepted and treated as mempty.
 466 deriveJSON (unPrefixUntagged "_") ''NgramsPatch
 467 makeLenses ''NgramsPatch
 468
 469 -- TODO: This instance is simplified since we should either have the fields children and/or list
 470 -- or the fields old and/or new.
 471 instance ToSchema NgramsPatch where
 472   declareNamedSchema _ = do
 473     childrenSch <- declareSchemaRef (Proxy :: Proxy (PatchMSet NgramsTerm))
 474     listSch <- declareSchemaRef (Proxy :: Proxy (Replace ListType))
 475     nreSch <- declareSchemaRef (Proxy :: Proxy NgramsRepoElement)
 476     return $ NamedSchema (Just "NgramsPatch") $ mempty
 477             & type_ ?~ SwaggerObject
 478             & properties .~
 479                 InsOrdHashMap.fromList
 480                 [ ("children", childrenSch)
 481                 , ("list",     listSch)
 482                 , ("old",      nreSch)
 483                 , ("new",      nreSch)
 484                 ]
 485 instance Arbitrary NgramsPatch where
 486   arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
 487                         , (1, NgramsReplace <$> arbitrary <*> arbitrary)
 488                         ]
 489 instance Serialise NgramsPatch
 490 instance FromField NgramsPatch where
 491   fromField = fromJSONField
 492 instance ToField NgramsPatch where
 493   toField = toJSONField
 494
 495 instance Serialise (Replace ListType)
 496
 497 instance Serialise ListType
 498
 499 type NgramsPatchIso =
 500   MaybePatch NgramsRepoElement (PairPatch (PatchMSet NgramsTerm) (Replace ListType))
 501
 502 _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
 503 _NgramsPatch = iso unwrap wrap
 504   where
 505     unwrap (NgramsPatch c l) = Mod $ PairPatch (c, l)
 506     unwrap (NgramsReplace o n) = replace o n
 507     wrap x =
 508       case unMod x of
 509         Just (PairPatch (c, l)) -> NgramsPatch c l
 510         Nothing -> NgramsReplace (x ^? old . _Just) (x ^? new . _Just)
 511
 512 instance Semigroup NgramsPatch where
 513   p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
 514
 515 instance Monoid NgramsPatch where
 516   mempty = _NgramsPatch # mempty
 517
 518 instance Validity NgramsPatch where
 519   validate p = p ^. _NgramsPatch . to validate
 520
 521 instance Transformable NgramsPatch where
 522   transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 523
 524   conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 525
 526   transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
 527     where
 528       (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 529
 530 type ConflictResolutionNgramsPatch =
 531   ( ConflictResolutionReplace (Maybe NgramsRepoElement)
 532   , ( ConflictResolutionPatchMSet NgramsTerm
 533     , ConflictResolutionReplace ListType
 534     )
 535   , (Bool, Bool)
 536   )
 537 type instance ConflictResolution NgramsPatch =
 538   ConflictResolutionNgramsPatch
 539
 540 type PatchedNgramsPatch = Maybe NgramsRepoElement
 541 type instance Patched NgramsPatch = PatchedNgramsPatch
 542
 543 instance Applicable (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
 544   applicable (PairPatch (c, l)) n = applicable c (n ^. nre_children) <> applicable l (n ^. nre_list)
 545
 546 instance Action (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
 547   act (PairPatch (c, l)) = (nre_children %~ act c)
 548                          . (nre_list     %~ act l)
 549
 550 instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
 551   applicable p = applicable (p ^. _NgramsPatch)
 552 instance Action NgramsPatch (Maybe NgramsRepoElement) where
 553   act p = act (p ^. _NgramsPatch)
 554
 555 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
 556   deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
 557
 558 mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch
 559 mkNgramsTablePatch = NgramsTablePatch . PM.fromMap
 560
 561 instance Serialise NgramsTablePatch
 562 instance Serialise (PatchMap NgramsTerm NgramsPatch)
 563
 564 instance FromField NgramsTablePatch
 565   where
 566     fromField = fromJSONField
 567     --fromField = fromField'
 568 instance ToField NgramsTablePatch
 569   where
 570     toField = toJSONField
 571
 572 instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
 573   where
 574     fromField = fromField'
 575
 576 type instance ConflictResolution NgramsTablePatch =
 577   NgramsTerm -> ConflictResolutionNgramsPatch
 578
 579
 580 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
 581   -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
 582 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
 583
 584 makePrisms ''NgramsTablePatch
 585 instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
 586 instance ToSchema  NgramsTablePatch
 587
 588 instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
 589   applicable p = applicable (p ^. _NgramsTablePatch)
 590
 591
 592 ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
 593 ngramsElementToRepo
 594   (NgramsElement { _ne_size     = s
 595                  , _ne_list     = l
 596                  , _ne_root     = r
 597                  , _ne_parent   = p
 598                  , _ne_children = c
 599                  }) =
 600   NgramsRepoElement
 601     { _nre_size     = s
 602     , _nre_list     = l
 603     , _nre_parent   = p
 604     , _nre_root     = r
 605     , _nre_children = c
 606     }
 607
 608 ngramsElementFromRepo :: NgramsTerm -> NgramsRepoElement -> NgramsElement
 609 ngramsElementFromRepo
 610   ngrams
 611   (NgramsRepoElement
 612       { _nre_size     = s
 613       , _nre_list     = l
 614       , _nre_parent   = p
 615       , _nre_root     = r
 616       , _nre_children = c
 617       }) =
 618   NgramsElement { _ne_size        = s
 619                 , _ne_list        = l
 620                 , _ne_root        = r
 621                 , _ne_parent      = p
 622                 , _ne_children    = c
 623                 , _ne_ngrams      = ngrams
 624                 , _ne_occurrences = mempty -- panic $ "API.Ngrams.Types._ne_occurrences"
 625                 {-
 626                 -- Here we could use 0 if we want to avoid any `panic`.
 627                 -- It will not happen using getTableNgrams if
 628                 -- getOccByNgramsOnly provides a count of occurrences for
 629                 -- all the ngrams given.
 630                 -}
 631                 }
 632
 633 reRootChildren :: NgramsTerm -> NgramsTerm -> State NgramsTableMap ()
 634 reRootChildren root ngram = do
 635   nre <- use $ at ngram
 636   forOf_ (_Just . nre_children . folded) nre $ \child -> do
 637     at child . _Just . nre_root ?= root
 638     reRootChildren root child
 639
 640 reParent :: Maybe RootParent -> NgramsTerm -> State NgramsTableMap ()
 641 reParent rp child = do
 642   at child . _Just %= ( (nre_parent .~ (_rp_parent <$> rp))
 643                       . (nre_root   .~ (_rp_root   <$> rp))
 644                       )
 645   reRootChildren (fromMaybe child (rp ^? _Just . rp_root)) child
 646
 647 reParentAddRem :: RootParent -> NgramsTerm -> AddRem -> State NgramsTableMap ()
 648 reParentAddRem rp child p =
 649   reParent (if isRem p then Nothing else Just rp) child
 650
 651 reParentNgramsPatch :: NgramsTerm -> NgramsPatch -> State NgramsTableMap ()
 652 reParentNgramsPatch parent ngramsPatch = do
 653   root_of_parent <- use (at parent . _Just . nre_root)
 654   let
 655     root = fromMaybe parent root_of_parent
 656     rp   = RootParent { _rp_root = root, _rp_parent = parent }
 657   itraverse_ (reParentAddRem rp) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
 658   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 659
 660 reParentNgramsTablePatch :: NgramsTablePatch -> State NgramsTableMap ()
 661 reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
 662   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 663
 664 ------------------------------------------------------------------------
 665
 666 instance Action NgramsTablePatch (Maybe NgramsTableMap) where
 667   act p =
 668     fmap (execState (reParentNgramsTablePatch p)) .
 669     act (p ^. _NgramsTablePatch)
 670
 671 instance Arbitrary NgramsTablePatch where
 672   arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
 673
 674 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
 675 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
 676 -- ntp_ngrams_patches = _NgramsTablePatch .  undefined
 677
 678 ------------------------------------------------------------------------
 679 type Version = Int
 680
 681 data Versioned a = Versioned
 682   { _v_version :: Version
 683   , _v_data    :: a
 684   }
 685   deriving (Generic, Show, Eq)
 686 deriveJSON (unPrefix "_v_") ''Versioned
 687 makeLenses ''Versioned
 688 instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where
 689   declareNamedSchema = wellNamedSchema "_v_"
 690 instance Arbitrary a => Arbitrary (Versioned a) where
 691   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 692 ------------------------------------------------------------------------
 693 type Count = Int
 694
 695 data VersionedWithCount a = VersionedWithCount
 696   { _vc_version :: Version
 697   , _vc_count   :: Count
 698   , _vc_data    :: a
 699   }
 700   deriving (Generic, Show, Eq)
 701 deriveJSON (unPrefix "_vc_") ''VersionedWithCount
 702 makeLenses ''VersionedWithCount
 703 instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where
 704   declareNamedSchema = wellNamedSchema "_vc_"
 705 instance Arbitrary a => Arbitrary (VersionedWithCount a) where
 706   arbitrary = VersionedWithCount 1 1 <$> arbitrary -- TODO 1 is constant so far
 707
 708 toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a
 709 toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_
 710 ------------------------------------------------------------------------
 711
 712 -- | TOREMOVE
 713 data Repo s p = Repo
 714   { _r_version :: !Version
 715   , _r_state   :: !s
 716   , _r_history :: ![p]
 717     -- first patch in the list is the most recent
 718   }
 719   deriving (Generic, Show)
 720
 721 ----------------------------------------------------------------------
 722
 723 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
 724   parseJSON = genericParseJSON $ unPrefix "_r_"
 725
 726 instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
 727   toJSON     = genericToJSON     $ unPrefix "_r_"
 728   toEncoding = genericToEncoding $ unPrefix "_r_"
 729
 730 instance (Serialise s, Serialise p) => Serialise (Repo s p)
 731
 732 makeLenses ''Repo
 733
 734 initRepo :: Monoid s => Repo s p
 735 initRepo = Repo 1 mempty []
 736
 737
 738
 739 --------------------
 740
 741 type RepoCmdM   env err m =
 742   ( CmdM'             env err m
 743   , HasConnectionPool env
 744   , HasConfig         env
 745   )
 746
 747
 748 ------------------------------------------------------------------------
 749
 750
 751 -- Instances
 752 instance Arbitrary NgramsRepoElement where
 753   arbitrary = elements $ map ngramsElementToRepo ns
 754     where
 755       NgramsTable ns = mockTable
 756
 757 instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
 758   where
 759     parseUrlPiece x = maybeToEither x (decode $ cs x)
 760
 761 instance ToHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap)) where
 762   toUrlPiece m = cs (encode m)
 763
 764 ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
 765 ngramsTypeFromTabType tabType =
 766   let here = "Garg.API.Ngrams: " :: Text in
 767     case tabType of
 768       Sources    -> TableNgrams.Sources
 769       Authors    -> TableNgrams.Authors
 770       Institutes -> TableNgrams.Institutes
 771       Terms      -> TableNgrams.NgramsTerms
 772       _          -> panic $ here <> "No Ngrams for this tab"
 773       -- TODO: This `panic` would disapear with custom NgramsType.
 774
 775 ----
 776 -- Async task
 777
 778 data UpdateTableNgramsCharts = UpdateTableNgramsCharts
 779   { _utn_tab_type :: !TabType
 780   , _utn_list_id  :: !ListId
 781   } deriving (Eq, Show, Generic)
 782
 783 makeLenses ''UpdateTableNgramsCharts
 784 instance FromJSON UpdateTableNgramsCharts where
 785   parseJSON = genericParseJSON $ jsonOptions "_utn_"
 786
 787 instance ToJSON UpdateTableNgramsCharts where
 788   toJSON = genericToJSON $ jsonOptions "_utn_"
 789
 790 instance ToSchema UpdateTableNgramsCharts where
 791   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_utn_")
 792
 793 ------------------------------------------------------------------------
 794 type NgramsList = (Map TableNgrams.NgramsType (Versioned NgramsTableMap))