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
11 {-# LANGUAGE ConstraintKinds #-}
12 {-# LANGUAGE ScopedTypeVariables #-}
13 {-# LANGUAGE TemplateHaskell #-}
14 {-# LANGUAGE TypeOperators #-}
15 {-# LANGUAGE TypeFamilies #-}
16 {-# OPTIONS -fno-warn-orphans #-}
18 module Gargantext.API.Ngrams.Types where
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(..))
29 import Data.Hashable (Hashable)
30 import Data.Map.Strict (Map)
31 import Data.Maybe (fromMaybe)
33 import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, MaybePatch(Mod), unMod, old, new)
35 import Data.String (IsString, fromString)
36 import Data.Swagger hiding (version, patch)
37 import Data.Text (Text, pack, strip)
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
62 ------------------------------------------------------------------------
64 type QueryParamR = QueryParam' '[Required, Strict]
66 ------------------------------------------------------------------------
67 --data FacetFormat = Table | Chart
68 data TabType = Docs | Trash | MoreFav | MoreTrash
69 | Terms | Sources | Authors | Institutes
71 deriving (Bounded, Enum, Eq, Generic, Ord, Show)
74 instance Hashable TabType
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
82 parseUrlPiece "Terms" = pure Terms
83 parseUrlPiece "Sources" = pure Sources
84 parseUrlPiece "Institutes" = pure Institutes
85 parseUrlPiece "Authors" = pure Authors
87 parseUrlPiece "Contacts" = pure Contacts
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
103 newtype MSet a = MSet (Map a ())
104 deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
106 instance ToJSON a => ToJSON (MSet a) where
107 toJSON (MSet m) = toJSON (Map.keys m)
108 toEncoding (MSet m) = toEncoding (Map.keys m)
110 mSetFromSet :: Set a -> MSet a
111 mSetFromSet = MSet . Map.fromSet (const ())
113 mSetFromList :: Ord a => [a] -> MSet a
114 mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
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
121 mSetToList :: MSet a -> [a]
122 mSetToList (MSet a) = Map.keys a
124 instance Foldable MSet where
125 foldMap f (MSet m) = Map.foldMapWithKey (\k _ -> f k) m
127 instance (Ord a, FromJSON a) => FromJSON (MSet a) where
128 parseJSON = fmap mSetFromList . parseJSON
130 instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
132 declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
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
147 data RootParent = RootParent
148 { _rp_root :: NgramsTerm
149 , _rp_parent :: NgramsTerm
151 deriving (Ord, Eq, Show, Generic)
153 deriveJSON (unPrefix "_rp_") ''RootParent
154 makeLenses ''RootParent
156 data NgramsRepoElement = NgramsRepoElement
158 , _nre_list :: !ListType
159 , _nre_root :: !(Maybe NgramsTerm)
160 , _nre_parent :: !(Maybe NgramsTerm)
161 , _nre_children :: !(MSet NgramsTerm)
163 deriving (Ord, Eq, Show, Generic)
164 deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
166 -- if ngrams & not size => size
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
177 instance Serialise (MSet NgramsTerm)
180 NgramsElement { _ne_ngrams :: NgramsTerm
182 , _ne_list :: ListType
183 , _ne_occurrences :: Set ContextId
184 , _ne_root :: Maybe NgramsTerm
185 , _ne_parent :: Maybe NgramsTerm
186 , _ne_children :: MSet NgramsTerm
188 deriving (Ord, Eq, Show, Generic)
190 deriveJSON (unPrefix "_ne_") ''NgramsElement
191 makeLenses ''NgramsElement
193 mkNgramsElement :: NgramsTerm
198 mkNgramsElement ngrams list rp children =
199 NgramsElement ngrams (size (unNgramsTerm ngrams)) list mempty (_rp_root <$> rp) (_rp_parent <$> rp) children
201 newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
202 newNgramsElement mayList ngrams =
203 mkNgramsElement ngrams (fromMaybe MapTerm mayList) Nothing mempty
205 instance ToSchema NgramsElement where
206 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
207 instance Arbitrary NgramsElement where
208 arbitrary = elements [newNgramsElement Nothing "sport"]
211 ------------------------------------------------------------------------
212 newtype NgramsTable = NgramsTable [NgramsElement]
213 deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
215 -- type NgramsList = NgramsTable
217 makePrisms ''NgramsTable
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
225 -- | TODO Check N and Weight
227 toNgramsElement :: [NgramsTableData] -> [NgramsElement]
228 toNgramsElement ns = map toNgramsElement' ns
230 toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
234 Just x -> lookup x mapParent
235 c' = maybe mempty identity $ lookup t mapChildren
236 lt' = maybe (panic "API.Ngrams: listypeId") identity lt
238 mapParent :: Map Int Text
239 mapParent = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
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
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
265 rp n = Just $ RootParent n n
267 instance Arbitrary NgramsTable where
268 arbitrary = pure mockTable
270 instance ToSchema NgramsTable
272 ------------------------------------------------------------------------
273 -- Searching in a Ngram Table
275 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
276 deriving (Generic, Enum, Bounded, Read, Show)
278 instance FromHttpApiData OrderBy
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"
286 instance ToHttpApiData OrderBy where
287 toUrlPiece = pack . show
289 instance ToParamSchema OrderBy
290 instance FromJSON OrderBy
291 instance ToJSON OrderBy
292 instance ToSchema OrderBy
293 instance Arbitrary OrderBy
295 arbitrary = elements [minBound..maxBound]
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)
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
317 data PatchSet a = PatchSet
321 deriving (Eq, Ord, Show, Generic)
323 makeLenses ''PatchSet
324 makePrisms ''PatchSet
326 instance ToJSON a => ToJSON (PatchSet a) where
327 toJSON = genericToJSON $ unPrefix "_"
328 toEncoding = genericToEncoding $ unPrefix "_"
330 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
331 parseJSON = genericParseJSON $ unPrefix "_"
334 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
335 arbitrary = PatchSet <$> arbitrary <*> arbitrary
337 type instance Patched (PatchSet a) = Set a
339 type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
340 type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
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
347 instance Ord a => Monoid (PatchSet a) where
348 mempty = PatchSet mempty mempty
350 instance Ord a => Group (PatchSet a) where
351 invert (PatchSet r a) = PatchSet a r
353 instance Ord a => Composable (PatchSet a) where
354 composable _ _ = undefined
356 instance Ord a => Action (PatchSet a) (Set a) where
357 act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
359 instance Applicable (PatchSet a) (Set a) where
360 applicable _ _ = mempty
362 instance Ord a => Validity (PatchSet a) where
363 validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
365 instance Ord a => Transformable (PatchSet a) where
366 transformable = undefined
368 conflicts _p _q = undefined
370 transformWith conflict p q = undefined conflict p q
372 instance ToSchema a => ToSchema (PatchSet a)
375 type AddRem = Replace (Maybe ())
377 instance Serialise AddRem
379 remPatch, addPatch :: AddRem
380 remPatch = replace (Just ()) Nothing
381 addPatch = replace Nothing (Just ())
383 isRem :: Replace (Maybe ()) -> Bool
384 isRem = (== remPatch)
386 type PatchMap = PM.PatchMap
388 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
389 deriving (Eq, Show, Generic, Validity, Semigroup, Monoid, Group,
390 Transformable, Composable)
392 unPatchMSet :: PatchMSet a -> PatchMap a AddRem
393 unPatchMSet (PatchMSet a) = a
395 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
396 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
398 instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
399 instance (Serialise a, Ord a) => Serialise (PatchMSet a)
401 -- TODO this breaks module abstraction
402 makePrisms ''PM.PatchMap
404 makePrisms ''PatchMSet
406 _PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
407 _PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
409 f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
410 f = Map.partition isRem >>> both %~ Map.keysSet
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
416 instance Ord a => Action (PatchMSet a) (MSet a) where
417 act (PatchMSet p) (MSet m) = MSet $ act p m
419 instance Ord a => Applicable (PatchMSet a) (MSet a) where
420 applicable (PatchMSet p) (MSet m) = applicable p m
422 instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
423 toJSON = toJSON . view _PatchMSetIso
424 toEncoding = toEncoding . view _PatchMSetIso
426 instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
427 parseJSON = fmap (_PatchMSetIso #) . parseJSON
429 instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
430 arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
432 instance ToSchema a => ToSchema (PatchMSet a) where
434 declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
436 type instance Patched (PatchMSet a) = MSet a
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.
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
449 InsOrdHashMap.fromList
453 & required .~ [ "old", "new" ]
456 = NgramsPatch { _patch_children :: !(PatchMSet NgramsTerm)
457 , _patch_list :: !(Replace ListType) -- TODO Map UserId ListType
459 | NgramsReplace { _patch_old :: !(Maybe NgramsRepoElement)
460 , _patch_new :: !(Maybe NgramsRepoElement)
462 deriving (Eq, Show, Generic)
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
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
479 InsOrdHashMap.fromList
480 [ ("children", childrenSch)
485 instance Arbitrary NgramsPatch where
486 arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
487 , (1, NgramsReplace <$> arbitrary <*> arbitrary)
489 instance Serialise NgramsPatch
490 instance FromField NgramsPatch where
491 fromField = fromJSONField
492 instance ToField NgramsPatch where
493 toField = toJSONField
495 instance Serialise (Replace ListType)
497 instance Serialise ListType
499 type NgramsPatchIso =
500 MaybePatch NgramsRepoElement (PairPatch (PatchMSet NgramsTerm) (Replace ListType))
502 _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
503 _NgramsPatch = iso unwrap wrap
505 unwrap (NgramsPatch c l) = Mod $ PairPatch (c, l)
506 unwrap (NgramsReplace o n) = replace o n
509 Just (PairPatch (c, l)) -> NgramsPatch c l
510 Nothing -> NgramsReplace (x ^? old . _Just) (x ^? new . _Just)
512 instance Semigroup NgramsPatch where
513 p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
515 instance Monoid NgramsPatch where
516 mempty = _NgramsPatch # mempty
518 instance Validity NgramsPatch where
519 validate p = p ^. _NgramsPatch . to validate
521 instance Transformable NgramsPatch where
522 transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
524 conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
526 transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
528 (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
530 type ConflictResolutionNgramsPatch =
531 ( ConflictResolutionReplace (Maybe NgramsRepoElement)
532 , ( ConflictResolutionPatchMSet NgramsTerm
533 , ConflictResolutionReplace ListType
537 type instance ConflictResolution NgramsPatch =
538 ConflictResolutionNgramsPatch
540 type PatchedNgramsPatch = Maybe NgramsRepoElement
541 type instance Patched NgramsPatch = PatchedNgramsPatch
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)
546 instance Action (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
547 act (PairPatch (c, l)) = (nre_children %~ act c)
548 . (nre_list %~ act l)
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)
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)
559 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
560 deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
562 mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch
563 mkNgramsTablePatch = NgramsTablePatch . PM.fromMap
565 instance Serialise NgramsTablePatch
566 instance Serialise (PatchMap NgramsTerm NgramsPatch)
568 instance FromField NgramsTablePatch
570 fromField = fromJSONField
571 --fromField = fromField'
572 instance ToField NgramsTablePatch
574 toField = toJSONField
576 instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
578 fromField = fromField'
580 type instance ConflictResolution NgramsTablePatch =
581 NgramsTerm -> ConflictResolutionNgramsPatch
584 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
585 -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
586 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
588 makePrisms ''NgramsTablePatch
589 instance ToSchema (PatchMap NgramsTerm NgramsPatch)
590 instance ToSchema NgramsTablePatch
592 instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
593 applicable p = applicable (p ^. _NgramsTablePatch)
596 ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
598 (NgramsElement { _ne_size = s
612 ngramsElementFromRepo :: NgramsTerm -> NgramsRepoElement -> NgramsElement
613 ngramsElementFromRepo
622 NgramsElement { _ne_size = s
627 , _ne_ngrams = ngrams
628 , _ne_occurrences = mempty -- panic $ "API.Ngrams.Types._ne_occurrences"
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.
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
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))
649 reRootChildren (fromMaybe child (rp ^? _Just . rp_root)) child
651 reParentAddRem :: RootParent -> NgramsTerm -> AddRem -> State NgramsTableMap ()
652 reParentAddRem rp child p =
653 reParent (if isRem p then Nothing else Just rp) child
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.
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)
665 root = fromMaybe parent root_of_parent
666 rp = RootParent { _rp_root = root, _rp_parent = parent }
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)
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
683 -> pure () -- ignore the patch and carry on.
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
689 reParentNgramsTablePatch :: NgramsTablePatch -> State NgramsTableMap ()
690 reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
691 -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
693 ------------------------------------------------------------------------
695 instance Action NgramsTablePatch (Maybe NgramsTableMap) where
697 fmap (execState (reParentNgramsTablePatch p)) .
698 act (p ^. _NgramsTablePatch)
700 instance Arbitrary NgramsTablePatch where
701 arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
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
707 ------------------------------------------------------------------------
710 data Versioned a = Versioned
711 { _v_version :: Version
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 ------------------------------------------------------------------------
724 data VersionedWithCount a = VersionedWithCount
725 { _vc_version :: Version
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
737 toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a
738 toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_
739 ------------------------------------------------------------------------
743 { _r_version :: !Version
746 -- first patch in the list is the most recent
748 deriving (Generic, Show)
750 ----------------------------------------------------------------------
752 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
753 parseJSON = genericParseJSON $ unPrefix "_r_"
755 instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
756 toJSON = genericToJSON $ unPrefix "_r_"
757 toEncoding = genericToEncoding $ unPrefix "_r_"
759 instance (Serialise s, Serialise p) => Serialise (Repo s p)
763 initRepo :: Monoid s => Repo s p
764 initRepo = Repo 1 mempty []
770 type RepoCmdM env err m =
772 , HasConnectionPool env
777 ------------------------------------------------------------------------
781 instance Arbitrary NgramsRepoElement where
782 arbitrary = elements $ map ngramsElementToRepo ns
784 NgramsTable ns = mockTable
786 instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
788 parseUrlPiece x = maybeToEither x (decode $ cs x)
790 instance ToHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap)) where
791 toUrlPiece m = cs (encode m)
793 ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
794 ngramsTypeFromTabType tabType =
795 let here = "Garg.API.Ngrams: " :: Text in
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.
807 data UpdateTableNgramsCharts = UpdateTableNgramsCharts
808 { _utn_tab_type :: !TabType
809 , _utn_list_id :: !ListId
810 } deriving (Eq, Show, Generic)
812 makeLenses ''UpdateTableNgramsCharts
813 instance FromJSON UpdateTableNgramsCharts where
814 parseJSON = genericParseJSON $ jsonOptions "_utn_"
816 instance ToJSON UpdateTableNgramsCharts where
817 toJSON = genericToJSON $ jsonOptions "_utn_"
819 instance ToSchema UpdateTableNgramsCharts where
820 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_utn_")
822 ------------------------------------------------------------------------
823 type NgramsList = (Map TableNgrams.NgramsType (Versioned NgramsTableMap))