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