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.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 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
 556   deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
 557
 558 instance Serialise NgramsTablePatch
 559 instance Serialise (PatchMap NgramsTerm NgramsPatch)
 560
 561 instance FromField NgramsTablePatch
 562   where
 563     fromField = fromJSONField
 564     --fromField = fromField'
 565 instance ToField NgramsTablePatch
 566   where
 567     toField = toJSONField
 568
 569 instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
 570   where
 571     fromField = fromField'
 572
 573 type instance ConflictResolution NgramsTablePatch =
 574   NgramsTerm -> ConflictResolutionNgramsPatch
 575
 576
 577 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
 578   -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
 579 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
 580
 581 makePrisms ''NgramsTablePatch
 582 instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
 583 instance ToSchema  NgramsTablePatch
 584
 585 instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
 586   applicable p = applicable (p ^. _NgramsTablePatch)
 587
 588
 589 ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
 590 ngramsElementToRepo
 591   (NgramsElement { _ne_size     = s
 592                  , _ne_list     = l
 593                  , _ne_root     = r
 594                  , _ne_parent   = p
 595                  , _ne_children = c
 596                  }) =
 597   NgramsRepoElement
 598     { _nre_size     = s
 599     , _nre_list     = l
 600     , _nre_parent   = p
 601     , _nre_root     = r
 602     , _nre_children = c
 603     }
 604
 605 ngramsElementFromRepo :: NgramsTerm -> NgramsRepoElement -> NgramsElement
 606 ngramsElementFromRepo
 607   ngrams
 608   (NgramsRepoElement
 609       { _nre_size     = s
 610       , _nre_list     = l
 611       , _nre_parent   = p
 612       , _nre_root     = r
 613       , _nre_children = c
 614       }) =
 615   NgramsElement { _ne_size        = s
 616                 , _ne_list        = l
 617                 , _ne_root        = r
 618                 , _ne_parent      = p
 619                 , _ne_children    = c
 620                 , _ne_ngrams      = ngrams
 621                 , _ne_occurrences = mempty -- panic $ "API.Ngrams.Types._ne_occurrences"
 622                 {-
 623                 -- Here we could use 0 if we want to avoid any `panic`.
 624                 -- It will not happen using getTableNgrams if
 625                 -- getOccByNgramsOnly provides a count of occurrences for
 626                 -- all the ngrams given.
 627                 -}
 628                 }
 629
 630 reRootChildren :: NgramsTerm -> ReParent NgramsTerm
 631 reRootChildren root ngram = do
 632   nre <- use $ at ngram
 633   forOf_ (_Just . nre_children . folded) nre $ \child -> do
 634     at child . _Just . nre_root ?= root
 635     reRootChildren root child
 636
 637 reParent :: Maybe RootParent -> ReParent NgramsTerm
 638 reParent rp child = do
 639   at child . _Just %= ( (nre_parent .~ (_rp_parent <$> rp))
 640                       . (nre_root   .~ (_rp_root   <$> rp))
 641                       )
 642   reRootChildren (fromMaybe child (rp ^? _Just . rp_root)) child
 643
 644 reParentAddRem :: RootParent -> NgramsTerm -> ReParent AddRem
 645 reParentAddRem rp child p =
 646   reParent (if isRem p then Nothing else Just rp) child
 647
 648 reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
 649 reParentNgramsPatch parent ngramsPatch = do
 650   root_of_parent <- use (at parent . _Just . nre_root)
 651   let
 652     root = fromMaybe parent root_of_parent
 653     rp   = RootParent { _rp_root = root, _rp_parent = parent }
 654   itraverse_ (reParentAddRem rp) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
 655   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 656
 657 reParentNgramsTablePatch :: ReParent NgramsTablePatch
 658 reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
 659   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 660
 661 ------------------------------------------------------------------------
 662
 663 instance Action NgramsTablePatch (Maybe NgramsTableMap) where
 664   act p =
 665     fmap (execState (reParentNgramsTablePatch p)) .
 666     act (p ^. _NgramsTablePatch)
 667
 668 instance Arbitrary NgramsTablePatch where
 669   arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
 670
 671 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
 672 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
 673 -- ntp_ngrams_patches = _NgramsTablePatch .  undefined
 674
 675 type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
 676
 677 ------------------------------------------------------------------------
 678 type Version = Int
 679
 680 data Versioned a = Versioned
 681   { _v_version :: Version
 682   , _v_data    :: a
 683   }
 684   deriving (Generic, Show, Eq)
 685 deriveJSON (unPrefix "_v_") ''Versioned
 686 makeLenses ''Versioned
 687 instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where
 688   declareNamedSchema = wellNamedSchema "_v_"
 689 instance Arbitrary a => Arbitrary (Versioned a) where
 690   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 691 ------------------------------------------------------------------------
 692 type Count = Int
 693
 694 data VersionedWithCount a = VersionedWithCount
 695   { _vc_version :: Version
 696   , _vc_count   :: Count
 697   , _vc_data    :: a
 698   }
 699   deriving (Generic, Show, Eq)
 700 deriveJSON (unPrefix "_vc_") ''VersionedWithCount
 701 makeLenses ''VersionedWithCount
 702 instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where
 703   declareNamedSchema = wellNamedSchema "_vc_"
 704 instance Arbitrary a => Arbitrary (VersionedWithCount a) where
 705   arbitrary = VersionedWithCount 1 1 <$> arbitrary -- TODO 1 is constant so far
 706
 707 toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a
 708 toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_
 709 ------------------------------------------------------------------------
 710
 711 -- | TOREMOVE
 712 data Repo s p = Repo
 713   { _r_version :: !Version
 714   , _r_state   :: !s
 715   , _r_history :: ![p]
 716     -- first patch in the list is the most recent
 717   }
 718   deriving (Generic, Show)
 719
 720 ----------------------------------------------------------------------
 721
 722 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
 723   parseJSON = genericParseJSON $ unPrefix "_r_"
 724
 725 instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
 726   toJSON     = genericToJSON     $ unPrefix "_r_"
 727   toEncoding = genericToEncoding $ unPrefix "_r_"
 728
 729 instance (Serialise s, Serialise p) => Serialise (Repo s p)
 730
 731 makeLenses ''Repo
 732
 733 initRepo :: Monoid s => Repo s p
 734 initRepo = Repo 1 mempty []
 735
 736
 737
 738 --------------------
 739
 740 type RepoCmdM   env err m =
 741   ( CmdM'             env err m
 742   , HasConnectionPool env
 743   , HasConfig         env
 744   )
 745
 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 instance ToHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap)) where
 761   toUrlPiece m = cs (encode m)
 762
 763 ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
 764 ngramsTypeFromTabType tabType =
 765   let here = "Garg.API.Ngrams: " :: Text in
 766     case tabType of
 767       Sources    -> TableNgrams.Sources
 768       Authors    -> TableNgrams.Authors
 769       Institutes -> TableNgrams.Institutes
 770       Terms      -> TableNgrams.NgramsTerms
 771       _          -> panic $ here <> "No Ngrams for this tab"
 772       -- TODO: This `panic` would disapear with custom NgramsType.
 773
 774 ----
 775 -- Async task
 776
 777 data UpdateTableNgramsCharts = UpdateTableNgramsCharts
 778   { _utn_tab_type :: !TabType
 779   , _utn_list_id  :: !ListId
 780   } deriving (Eq, Show, Generic)
 781
 782 makeLenses ''UpdateTableNgramsCharts
 783 instance FromJSON UpdateTableNgramsCharts where
 784   parseJSON = genericParseJSON $ jsonOptions "_utn_"
 785
 786 instance ToJSON UpdateTableNgramsCharts where
 787   toJSON = genericToJSON $ jsonOptions "_utn_"
 788
 789 instance ToSchema UpdateTableNgramsCharts where
 790   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_utn_")
 791
 792 ------------------------------------------------------------------------
 793 type NgramsList = (Map TableNgrams.NgramsType (Versioned NgramsTableMap))