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