src/Gargantext/API/Ngrams/Types.hs

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