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