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 Data.Hashable (Hashable)
  23 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
  24 import qualified Data.List as List
  25 import Data.Map.Strict (Map)
  26 import qualified Data.Map.Strict as Map
  27 import qualified Data.Map.Strict.Patch as PM
  28 import Data.Maybe (fromMaybe)
  29 import Data.Monoid
  30 import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..),
  31                          PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace,
  32                          MaybePatch(Mod), unMod, old, new)
  33 import Data.Set (Set)
  34 import qualified Data.Set as Set
  35 import Data.String (IsString, fromString)
  36 import Data.Swagger hiding (version, patch)
  37 import Data.Text (Text, pack, strip)
  38 import Data.Validity
  39 import Database.PostgreSQL.Simple.FromField (FromField, fromField, ResultError(ConversionFailed), returnError)
  40 import GHC.Generics (Generic)
  41 import Servant hiding (Patch)
  42 import Servant.Job.Utils (jsonOptions)
  43 import System.FileLock (FileLock)
  44 import Test.QuickCheck (elements, frequency)
  45 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  46
  47 import Protolude (maybeToEither)
  48 import Gargantext.Prelude
  49
  50 import Gargantext.Core.Text (size)
  51 import Gargantext.Core.Types (ListType(..), ListId, NodeId)
  52 import Gargantext.Core.Types (TODO)
  53 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger, wellNamedSchema)
  54 import Gargantext.Database.Prelude (fromField', CmdM', HasConnectionPool, HasConfig)
  55 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
  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
  68    where
  69     parseUrlPiece "Docs"       = pure Docs
  70     parseUrlPiece "Trash"      = pure Trash
  71     parseUrlPiece "MoreFav"    = pure MoreFav
  72     parseUrlPiece "MoreTrash"  = pure MoreTrash
  73
  74     parseUrlPiece "Terms"      = pure Terms
  75     parseUrlPiece "Sources"    = pure Sources
  76     parseUrlPiece "Institutes" = pure Institutes
  77     parseUrlPiece "Authors"    = pure Authors
  78
  79     parseUrlPiece "Contacts"   = pure Contacts
  80
  81     parseUrlPiece _            = Left "Unexpected value of TabType"
  82 instance ToParamSchema TabType
  83 instance ToJSON        TabType
  84 instance FromJSON      TabType
  85 instance ToSchema      TabType
  86 instance Arbitrary     TabType
  87   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)
 128
 129 instance FromJSONKey NgramsTerm where
 130   fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t
 131
 132 instance IsString NgramsTerm where
 133   fromString s = NgramsTerm $ pack s
 134
 135 instance FromField NgramsTerm
 136   where
 137     fromField field mb = do
 138       v <- fromField field mb
 139       case fromJSON v of
 140         Success a -> pure $ NgramsTerm $ strip a
 141         Error _err -> returnError ConversionFailed field
 142                       $ List.intercalate " " [ "cannot parse hyperdata for JSON: "
 143                                              , show v
 144                                              ]
 145
 146 data RootParent = RootParent
 147   { _rp_root   :: NgramsTerm
 148   , _rp_parent :: NgramsTerm
 149   }
 150   deriving (Ord, Eq, Show, Generic)
 151
 152 deriveJSON (unPrefix "_rp_") ''RootParent
 153 makeLenses ''RootParent
 154
 155 data NgramsRepoElement = NgramsRepoElement
 156   { _nre_size        :: !Int
 157   , _nre_list        :: !ListType
 158   , _nre_root        :: !(Maybe NgramsTerm)
 159   , _nre_parent      :: !(Maybe NgramsTerm)
 160   , _nre_children    :: !(MSet NgramsTerm)
 161   }
 162   deriving (Ord, Eq, Show, Generic)
 163
 164 deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
 165 -- TODO
 166 -- if ngrams & not size => size
 167 -- drop occurrences
 168
 169 makeLenses ''NgramsRepoElement
 170
 171 instance ToSchema NgramsRepoElement where
 172   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
 173
 174 instance Serialise (MSet NgramsTerm)
 175 instance Serialise NgramsRepoElement
 176
 177 data NgramsElement =
 178      NgramsElement { _ne_ngrams      :: NgramsTerm
 179                    , _ne_size        :: Int
 180                    , _ne_list        :: ListType
 181                    , _ne_occurrences :: Int
 182                    , _ne_root        :: Maybe NgramsTerm
 183                    , _ne_parent      :: Maybe NgramsTerm
 184                    , _ne_children    :: MSet  NgramsTerm
 185                    }
 186       deriving (Ord, Eq, Show, Generic)
 187
 188 deriveJSON (unPrefix "_ne_") ''NgramsElement
 189 makeLenses ''NgramsElement
 190
 191 mkNgramsElement :: NgramsTerm
 192                 -> ListType
 193                 -> Maybe RootParent
 194                 -> MSet NgramsTerm
 195                 -> NgramsElement
 196 mkNgramsElement ngrams list rp children =
 197   NgramsElement ngrams (size (unNgramsTerm ngrams)) list 1 (_rp_root <$> rp) (_rp_parent <$> rp) children
 198
 199 newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
 200 newNgramsElement mayList ngrams =
 201   mkNgramsElement ngrams (fromMaybe MapTerm mayList) Nothing mempty
 202
 203 instance ToSchema NgramsElement where
 204   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
 205 instance Arbitrary NgramsElement where
 206   arbitrary = elements [newNgramsElement Nothing "sport"]
 207
 208
 209 ------------------------------------------------------------------------
 210 newtype NgramsTable = NgramsTable [NgramsElement]
 211   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 212
 213 type NgramsList = NgramsTable
 214
 215 makePrisms ''NgramsTable
 216
 217 -- | Question: why these repetition of Type in this instance
 218 -- may you document it please ?
 219 instance Each NgramsTable NgramsTable NgramsElement NgramsElement where
 220   each = _NgramsTable . each
 221
 222 -- TODO discuss
 223 -- | TODO Check N and Weight
 224 {-
 225 toNgramsElement :: [NgramsTableData] -> [NgramsElement]
 226 toNgramsElement ns = map toNgramsElement' ns
 227     where
 228       toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
 229         where
 230           p' = case p of
 231                  Nothing -> Nothing
 232                  Just x  -> lookup x mapParent
 233           c' = maybe mempty identity $ lookup t mapChildren
 234           lt' = maybe (panic "API.Ngrams: listypeId") identity lt
 235
 236       mapParent :: Map Int Text
 237       mapParent   = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
 238
 239       mapChildren :: Map Text (Set Text)
 240       mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
 241                   $ Map.fromListWith (<>)
 242                   $ map (first fromJust)
 243                   $ filter (isJust . fst)
 244                   $ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
 245 -}
 246
 247 mockTable :: NgramsTable
 248 mockTable = NgramsTable
 249   [ mkNgramsElement "animal"  MapTerm      Nothing       (mSetFromList ["dog", "cat"])
 250   , mkNgramsElement "cat"     MapTerm     (rp "animal")  mempty
 251   , mkNgramsElement "cats"    StopTerm       Nothing       mempty
 252   , mkNgramsElement "dog"     MapTerm     (rp "animal")  (mSetFromList ["dogs"])
 253   , mkNgramsElement "dogs"    StopTerm      (rp "dog")     mempty
 254   , mkNgramsElement "fox"     MapTerm      Nothing       mempty
 255   , mkNgramsElement "object"  CandidateTerm  Nothing       mempty
 256   , mkNgramsElement "nothing" StopTerm       Nothing       mempty
 257   , mkNgramsElement "organic" MapTerm      Nothing       (mSetFromList ["flower"])
 258   , mkNgramsElement "flower"  MapTerm     (rp "organic") mempty
 259   , mkNgramsElement "moon"    CandidateTerm  Nothing       mempty
 260   , mkNgramsElement "sky"     StopTerm       Nothing       mempty
 261   ]
 262   where
 263     rp n = Just $ RootParent n n
 264
 265 instance Arbitrary NgramsTable where
 266   arbitrary = pure mockTable
 267
 268 instance ToSchema NgramsTable
 269
 270 ------------------------------------------------------------------------
 271 type NgramsTableMap = Map NgramsTerm NgramsRepoElement
 272 ------------------------------------------------------------------------
 273 -- On the Client side:
 274 --data Action = InGroup     NgramsId NgramsId
 275 --            | OutGroup    NgramsId NgramsId
 276 --            | SetListType NgramsId ListType
 277
 278 data PatchSet a = PatchSet
 279   { _rem :: Set a
 280   , _add :: Set a
 281   }
 282   deriving (Eq, Ord, Show, Generic)
 283
 284 makeLenses ''PatchSet
 285 makePrisms ''PatchSet
 286
 287 instance ToJSON a => ToJSON (PatchSet a) where
 288   toJSON     = genericToJSON     $ unPrefix "_"
 289   toEncoding = genericToEncoding $ unPrefix "_"
 290
 291 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
 292   parseJSON = genericParseJSON $ unPrefix "_"
 293
 294 {-
 295 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 296   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 297
 298 type instance Patched (PatchSet a) = Set a
 299
 300 type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
 301 type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
 302
 303 instance Ord a => Semigroup (PatchSet a) where
 304   p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem
 305                     , _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add
 306                     } -- TODO Review
 307
 308 instance Ord a => Monoid (PatchSet a) where
 309   mempty = PatchSet mempty mempty
 310
 311 instance Ord a => Group (PatchSet a) where
 312   invert (PatchSet r a) = PatchSet a r
 313
 314 instance Ord a => Composable (PatchSet a) where
 315   composable _ _ = undefined
 316
 317 instance Ord a => Action (PatchSet a) (Set a) where
 318   act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
 319
 320 instance Applicable (PatchSet a) (Set a) where
 321   applicable _ _ = mempty
 322
 323 instance Ord a => Validity (PatchSet a) where
 324   validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
 325
 326 instance Ord a => Transformable (PatchSet a) where
 327   transformable = undefined
 328
 329   conflicts _p _q = undefined
 330
 331   transformWith conflict p q = undefined conflict p q
 332
 333 instance ToSchema a => ToSchema (PatchSet a)
 334 -}
 335
 336 type AddRem = Replace (Maybe ())
 337
 338 instance Serialise AddRem
 339
 340 remPatch, addPatch :: AddRem
 341 remPatch = replace (Just ()) Nothing
 342 addPatch = replace Nothing (Just ())
 343
 344 isRem :: Replace (Maybe ()) -> Bool
 345 isRem = (== remPatch)
 346
 347 type PatchMap = PM.PatchMap
 348
 349 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
 350   deriving (Eq, Show, Generic, Validity, Semigroup, Monoid, Group,
 351             Transformable, Composable)
 352
 353 unPatchMSet :: PatchMSet a -> PatchMap a AddRem
 354 unPatchMSet (PatchMSet a) = a
 355
 356 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
 357 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
 358
 359 instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
 360 instance (Serialise a, Ord a) => Serialise (PatchMSet a)
 361
 362 -- TODO this breaks module abstraction
 363 makePrisms ''PM.PatchMap
 364
 365 makePrisms ''PatchMSet
 366
 367 _PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
 368 _PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
 369   where
 370     f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
 371     f = Map.partition isRem >>> both %~ Map.keysSet
 372
 373     g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
 374     g (rems, adds) = Map.fromSet (const remPatch) rems
 375                   <> Map.fromSet (const addPatch) adds
 376
 377 instance Ord a => Action (PatchMSet a) (MSet a) where
 378   act (PatchMSet p) (MSet m) = MSet $ act p m
 379
 380 instance Ord a => Applicable (PatchMSet a) (MSet a) where
 381   applicable (PatchMSet p) (MSet m) = applicable p m
 382
 383 instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
 384   toJSON     = toJSON . view _PatchMSetIso
 385   toEncoding = toEncoding . view _PatchMSetIso
 386
 387 instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
 388   parseJSON = fmap (_PatchMSetIso #) . parseJSON
 389
 390 instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
 391   arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
 392
 393 instance ToSchema a => ToSchema (PatchMSet a) where
 394   -- TODO
 395   declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
 396
 397 type instance Patched (PatchMSet a) = MSet a
 398
 399 instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
 400   arbitrary = uncurry replace <$> arbitrary
 401     -- If they happen to be equal then the patch is Keep.
 402
 403 instance ToSchema a => ToSchema (Replace a) where
 404   declareNamedSchema (_ :: Proxy (Replace a)) = do
 405     -- TODO Keep constructor is not supported here.
 406     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 407     return $ NamedSchema (Just "Replace") $ mempty
 408             & type_ ?~ SwaggerObject
 409             & properties .~
 410                 InsOrdHashMap.fromList
 411                 [ ("old", aSchema)
 412                 , ("new", aSchema)
 413                 ]
 414             & required .~ [ "old", "new" ]
 415
 416 data NgramsPatch
 417    = NgramsPatch { _patch_children :: !(PatchMSet NgramsTerm)
 418                  , _patch_list     :: !(Replace ListType)   -- TODO Map UserId ListType
 419                  }
 420    | NgramsReplace { _patch_old :: !(Maybe NgramsRepoElement)
 421                    , _patch_new :: !(Maybe NgramsRepoElement)
 422                    }
 423       deriving (Eq, Show, Generic)
 424
 425 -- The JSON encoding is untagged, this is OK since the field names are disjoints and thus the encoding is unambiguous.
 426 -- TODO: the empty object should be accepted and treated as mempty.
 427 deriveJSON (unPrefixUntagged "_") ''NgramsPatch
 428 makeLenses ''NgramsPatch
 429
 430 -- TODO: This instance is simplified since we should either have the fields children and/or list
 431 -- or the fields old and/or new.
 432 instance ToSchema NgramsPatch where
 433   declareNamedSchema _ = do
 434     childrenSch <- declareSchemaRef (Proxy :: Proxy (PatchMSet NgramsTerm))
 435     listSch <- declareSchemaRef (Proxy :: Proxy (Replace ListType))
 436     nreSch <- declareSchemaRef (Proxy :: Proxy NgramsRepoElement)
 437     return $ NamedSchema (Just "NgramsPatch") $ mempty
 438             & type_ ?~ SwaggerObject
 439             & properties .~
 440                 InsOrdHashMap.fromList
 441                 [ ("children", childrenSch)
 442                 , ("list",     listSch)
 443                 , ("old",      nreSch)
 444                 , ("new",      nreSch)
 445                 ]
 446
 447 instance Arbitrary NgramsPatch where
 448   arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
 449                         , (1, NgramsReplace <$> arbitrary <*> arbitrary)
 450                         ]
 451
 452 instance Serialise NgramsPatch
 453 instance Serialise (Replace ListType)
 454
 455 instance Serialise ListType
 456
 457 type NgramsPatchIso =
 458   MaybePatch NgramsRepoElement (PairPatch (PatchMSet NgramsTerm) (Replace ListType))
 459
 460 _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
 461 _NgramsPatch = iso unwrap wrap
 462   where
 463     unwrap (NgramsPatch c l) = Mod $ PairPatch (c, l)
 464     unwrap (NgramsReplace o n) = replace o n
 465     wrap x =
 466       case unMod x of
 467         Just (PairPatch (c, l)) -> NgramsPatch c l
 468         Nothing -> NgramsReplace (x ^? old . _Just) (x ^? new . _Just)
 469
 470 instance Semigroup NgramsPatch where
 471   p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
 472
 473 instance Monoid NgramsPatch where
 474   mempty = _NgramsPatch # mempty
 475
 476 instance Validity NgramsPatch where
 477   validate p = p ^. _NgramsPatch . to validate
 478
 479 instance Transformable NgramsPatch where
 480   transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 481
 482   conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 483
 484   transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
 485     where
 486       (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 487
 488 type ConflictResolutionNgramsPatch =
 489   ( ConflictResolutionReplace (Maybe NgramsRepoElement)
 490   , ( ConflictResolutionPatchMSet NgramsTerm
 491     , ConflictResolutionReplace ListType
 492     )
 493   , (Bool, Bool)
 494   )
 495 type instance ConflictResolution NgramsPatch =
 496   ConflictResolutionNgramsPatch
 497
 498 type PatchedNgramsPatch = Maybe NgramsRepoElement
 499 type instance Patched NgramsPatch = PatchedNgramsPatch
 500
 501 instance Applicable (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
 502   applicable (PairPatch (c, l)) n = applicable c (n ^. nre_children) <> applicable l (n ^. nre_list)
 503
 504 instance Action (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
 505   act (PairPatch (c, l)) = (nre_children %~ act c)
 506                          . (nre_list     %~ act l)
 507
 508 instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
 509   applicable p = applicable (p ^. _NgramsPatch)
 510
 511 instance Action NgramsPatch (Maybe NgramsRepoElement) where
 512   act p = act (p ^. _NgramsPatch)
 513
 514 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
 515   deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
 516
 517 instance Serialise NgramsTablePatch
 518 instance Serialise (PatchMap NgramsTerm NgramsPatch)
 519
 520 instance FromField NgramsTablePatch
 521   where
 522     fromField = fromField'
 523
 524 instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
 525   where
 526     fromField = fromField'
 527
 528 type instance ConflictResolution NgramsTablePatch =
 529   NgramsTerm -> ConflictResolutionNgramsPatch
 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._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 ------------------------------------------------------------------------
 647 data Repo s p = Repo
 648   { _r_version :: !Version
 649   , _r_state   :: !s
 650   , _r_history :: ![p]
 651     -- first patch in the list is the most recent
 652   }
 653   deriving (Generic, Show)
 654
 655 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
 656   parseJSON = genericParseJSON $ unPrefix "_r_"
 657
 658 instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
 659   toJSON     = genericToJSON     $ unPrefix "_r_"
 660   toEncoding = genericToEncoding $ unPrefix "_r_"
 661
 662 instance (Serialise s, Serialise p) => Serialise (Repo s p)
 663
 664 makeLenses ''Repo
 665
 666 initRepo :: Monoid s => Repo s p
 667 initRepo = Repo 1 mempty []
 668
 669 type NgramsRepo       = Repo NgramsState NgramsStatePatch
 670 type NgramsState      = Map      TableNgrams.NgramsType (Map NodeId NgramsTableMap)
 671 type NgramsStatePatch = PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch)
 672
 673 instance Serialise (PM.PatchMap NodeId NgramsTablePatch)
 674 instance Serialise NgramsStatePatch
 675
 676 initMockRepo :: NgramsRepo
 677 initMockRepo = Repo 1 s []
 678   where
 679     s = Map.singleton TableNgrams.NgramsTerms
 680       $ Map.singleton 47254
 681       $ Map.fromList
 682       [ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ]
 683
 684 data RepoEnv = RepoEnv
 685   { _renv_var   :: !(MVar NgramsRepo)
 686   , _renv_saver :: !(IO ())
 687   , _renv_lock  :: !FileLock
 688   }
 689   deriving (Generic)
 690
 691 makeLenses ''RepoEnv
 692
 693 class HasRepoVar env where
 694   repoVar :: Getter env (MVar NgramsRepo)
 695
 696 instance HasRepoVar (MVar NgramsRepo) where
 697   repoVar = identity
 698
 699 class HasRepoSaver env where
 700   repoSaver :: Getter env (IO ())
 701
 702 class (HasRepoVar env, HasRepoSaver env) => HasRepo env where
 703   repoEnv :: Getter env RepoEnv
 704
 705 instance HasRepo RepoEnv where
 706   repoEnv = identity
 707
 708 instance HasRepoVar RepoEnv where
 709   repoVar = renv_var
 710
 711 instance HasRepoSaver RepoEnv where
 712   repoSaver = renv_saver
 713
 714 type RepoCmdM   env err m =
 715   ( CmdM'             env err m
 716   , HasRepo           env
 717   , HasConnectionPool env
 718   , HasConfig         env
 719   )
 720
 721
 722 type QueryParamR = QueryParam' '[Required, Strict]
 723
 724
 725 -- Instances
 726 instance Arbitrary NgramsRepoElement where
 727   arbitrary = elements $ map ngramsElementToRepo ns
 728     where
 729       NgramsTable ns = mockTable
 730
 731 --{-
 732 instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
 733   where
 734     parseUrlPiece x = maybeToEither x (decode $ cs x)
 735
 736
 737 ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
 738 ngramsTypeFromTabType tabType =
 739   let lieu = "Garg.API.Ngrams: " :: Text in
 740     case tabType of
 741       Sources    -> TableNgrams.Sources
 742       Authors    -> TableNgrams.Authors
 743       Institutes -> TableNgrams.Institutes
 744       Terms      -> TableNgrams.NgramsTerms
 745       _          -> panic $ lieu <> "No Ngrams for this tab"
 746       -- TODO: This `panic` would disapear with custom NgramsType.
 747
 748 ----
 749 -- Async task
 750
 751 data UpdateTableNgramsCharts = UpdateTableNgramsCharts
 752   { _utn_tab_type :: !TabType
 753   , _utn_list_id  :: !ListId
 754   } deriving (Eq, Show, Generic)
 755
 756 makeLenses ''UpdateTableNgramsCharts
 757 instance FromJSON UpdateTableNgramsCharts where
 758   parseJSON = genericParseJSON $ jsonOptions "_utn_"
 759 instance ToSchema UpdateTableNgramsCharts where
 760   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_utn_")