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