src/Gargantext/API/Ngrams/Types.hs

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