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