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