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