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