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