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