src/Gargantext/API/Ngrams/Types.hs

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