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
 346 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
 347   deriving (Eq, Show, Generic, Validity, Semigroup, Monoid, Group,
 348             Transformable, Composable)
 349
 350 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
 351 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
 352
 353 instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
 354 instance (Serialise a, Ord a) => Serialise (PatchMSet a)
 355
 356 -- TODO this breaks module abstraction
 357 makePrisms ''PM.PatchMap
 358
 359 makePrisms ''PatchMSet
 360
 361 _PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
 362 _PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
 363   where
 364     f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
 365     f = Map.partition isRem >>> both %~ Map.keysSet
 366
 367     g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
 368     g (rems, adds) = Map.fromSet (const remPatch) rems
 369                   <> Map.fromSet (const addPatch) adds
 370
 371 instance Ord a => Action (PatchMSet a) (MSet a) where
 372   act (PatchMSet p) (MSet m) = MSet $ act p m
 373
 374 instance Ord a => Applicable (PatchMSet a) (MSet a) where
 375   applicable (PatchMSet p) (MSet m) = applicable p m
 376
 377 instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
 378   toJSON     = toJSON . view _PatchMSetIso
 379   toEncoding = toEncoding . view _PatchMSetIso
 380
 381 instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
 382   parseJSON = fmap (_PatchMSetIso #) . parseJSON
 383
 384 instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
 385   arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
 386
 387 instance ToSchema a => ToSchema (PatchMSet a) where
 388   -- TODO
 389   declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
 390
 391 type instance Patched (PatchMSet a) = MSet a
 392
 393 instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
 394   arbitrary = uncurry replace <$> arbitrary
 395     -- If they happen to be equal then the patch is Keep.
 396
 397 instance ToSchema a => ToSchema (Replace a) where
 398   declareNamedSchema (_ :: Proxy (Replace a)) = do
 399     -- TODO Keep constructor is not supported here.
 400     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 401     return $ NamedSchema (Just "Replace") $ mempty
 402             & type_ ?~ SwaggerObject
 403             & properties .~
 404                 InsOrdHashMap.fromList
 405                 [ ("old", aSchema)
 406                 , ("new", aSchema)
 407                 ]
 408             & required .~ [ "old", "new" ]
 409
 410 data NgramsPatch
 411    = NgramsPatch { _patch_children :: !(PatchMSet NgramsTerm)
 412                  , _patch_list     :: !(Replace ListType)   -- TODO Map UserId ListType
 413                  }
 414    | NgramsReplace { _patch_old :: !(Maybe NgramsRepoElement)
 415                    , _patch_new :: !(Maybe NgramsRepoElement)
 416                    }
 417       deriving (Eq, Show, Generic)
 418
 419 -- The JSON encoding is untagged, this is OK since the field names are disjoints and thus the encoding is unambiguous.
 420 -- TODO: the empty object should be accepted and treated as mempty.
 421 deriveJSON (unPrefixUntagged "_") ''NgramsPatch
 422 makeLenses ''NgramsPatch
 423
 424 -- TODO: This instance is simplified since we should either have the fields children and/or list
 425 -- or the fields old and/or new.
 426 instance ToSchema NgramsPatch where
 427   declareNamedSchema _ = do
 428     childrenSch <- declareSchemaRef (Proxy :: Proxy (PatchMSet NgramsTerm))
 429     listSch <- declareSchemaRef (Proxy :: Proxy (Replace ListType))
 430     nreSch <- declareSchemaRef (Proxy :: Proxy NgramsRepoElement)
 431     return $ NamedSchema (Just "NgramsPatch") $ mempty
 432             & type_ ?~ SwaggerObject
 433             & properties .~
 434                 InsOrdHashMap.fromList
 435                 [ ("children", childrenSch)
 436                 , ("list",     listSch)
 437                 , ("old",      nreSch)
 438                 , ("new",      nreSch)
 439                 ]
 440
 441 instance Arbitrary NgramsPatch where
 442   arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
 443                         , (1, NgramsReplace <$> arbitrary <*> arbitrary)
 444                         ]
 445
 446 instance Serialise NgramsPatch
 447 instance Serialise (Replace ListType)
 448
 449 instance Serialise ListType
 450
 451 type NgramsPatchIso =
 452   MaybePatch NgramsRepoElement (PairPatch (PatchMSet NgramsTerm) (Replace ListType))
 453
 454 _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
 455 _NgramsPatch = iso unwrap wrap
 456   where
 457     unwrap (NgramsPatch c l) = Mod $ PairPatch (c, l)
 458     unwrap (NgramsReplace o n) = replace o n
 459     wrap x =
 460       case unMod x of
 461         Just (PairPatch (c, l)) -> NgramsPatch c l
 462         Nothing -> NgramsReplace (x ^? old . _Just) (x ^? new . _Just)
 463
 464 instance Semigroup NgramsPatch where
 465   p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
 466
 467 instance Monoid NgramsPatch where
 468   mempty = _NgramsPatch # mempty
 469
 470 instance Validity NgramsPatch where
 471   validate p = p ^. _NgramsPatch . to validate
 472
 473 instance Transformable NgramsPatch where
 474   transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 475
 476   conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 477
 478   transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
 479     where
 480       (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 481
 482 type ConflictResolutionNgramsPatch =
 483   ( ConflictResolutionReplace (Maybe NgramsRepoElement)
 484   , ( ConflictResolutionPatchMSet NgramsTerm
 485     , ConflictResolutionReplace ListType
 486     )
 487   , (Bool, Bool)
 488   )
 489 type instance ConflictResolution NgramsPatch =
 490   ConflictResolutionNgramsPatch
 491
 492 type PatchedNgramsPatch = Maybe NgramsRepoElement
 493 type instance Patched NgramsPatch = PatchedNgramsPatch
 494
 495 instance Applicable (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
 496   applicable (PairPatch (c, l)) n = applicable c (n ^. nre_children) <> applicable l (n ^. nre_list)
 497
 498 instance Action (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
 499   act (PairPatch (c, l)) = (nre_children %~ act c)
 500                          . (nre_list     %~ act l)
 501
 502 instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
 503   applicable p = applicable (p ^. _NgramsPatch)
 504
 505 instance Action NgramsPatch (Maybe NgramsRepoElement) where
 506   act p = act (p ^. _NgramsPatch)
 507
 508 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
 509   deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
 510
 511 instance Serialise NgramsTablePatch
 512 instance Serialise (PatchMap NgramsTerm NgramsPatch)
 513
 514 instance FromField NgramsTablePatch
 515   where
 516     fromField = fromField'
 517
 518 instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
 519   where
 520     fromField = fromField'
 521
 522 type instance ConflictResolution NgramsTablePatch =
 523   NgramsTerm -> ConflictResolutionNgramsPatch
 524
 525 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
 526   -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
 527 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
 528
 529 makePrisms ''NgramsTablePatch
 530 instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
 531 instance ToSchema  NgramsTablePatch
 532
 533 instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
 534   applicable p = applicable (p ^. _NgramsTablePatch)
 535
 536
 537 ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
 538 ngramsElementToRepo
 539   (NgramsElement { _ne_size     = s
 540                  , _ne_list     = l
 541                  , _ne_root     = r
 542                  , _ne_parent   = p
 543                  , _ne_children = c
 544                  }) =
 545   NgramsRepoElement
 546     { _nre_size     = s
 547     , _nre_list     = l
 548     , _nre_parent   = p
 549     , _nre_root     = r
 550     , _nre_children = c
 551     }
 552
 553 ngramsElementFromRepo :: NgramsTerm -> NgramsRepoElement -> NgramsElement
 554 ngramsElementFromRepo
 555   ngrams
 556   (NgramsRepoElement
 557       { _nre_size     = s
 558       , _nre_list     = l
 559       , _nre_parent   = p
 560       , _nre_root     = r
 561       , _nre_children = c
 562       }) =
 563   NgramsElement { _ne_size        = s
 564                 , _ne_list        = l
 565                 , _ne_root        = r
 566                 , _ne_parent      = p
 567                 , _ne_children    = c
 568                 , _ne_ngrams      = ngrams
 569                 , _ne_occurrences = panic $ "API.Ngrams._ne_occurrences"
 570                 {-
 571                 -- Here we could use 0 if we want to avoid any `panic`.
 572                 -- It will not happen using getTableNgrams if
 573                 -- getOccByNgramsOnly provides a count of occurrences for
 574                 -- all the ngrams given.
 575                 -}
 576                 }
 577
 578 reRootChildren :: NgramsTerm -> ReParent NgramsTerm
 579 reRootChildren root ngram = do
 580   nre <- use $ at ngram
 581   forOf_ (_Just . nre_children . folded) nre $ \child -> do
 582     at child . _Just . nre_root ?= root
 583     reRootChildren root child
 584
 585 reParent :: Maybe RootParent -> ReParent NgramsTerm
 586 reParent rp child = do
 587   at child . _Just %= ( (nre_parent .~ (_rp_parent <$> rp))
 588                       . (nre_root   .~ (_rp_root   <$> rp))
 589                       )
 590   reRootChildren (fromMaybe child (rp ^? _Just . rp_root)) child
 591
 592 reParentAddRem :: RootParent -> NgramsTerm -> ReParent AddRem
 593 reParentAddRem rp child p =
 594   reParent (if isRem p then Nothing else Just rp) child
 595
 596 reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
 597 reParentNgramsPatch parent ngramsPatch = do
 598   root_of_parent <- use (at parent . _Just . nre_root)
 599   let
 600     root = fromMaybe parent root_of_parent
 601     rp   = RootParent { _rp_root = root, _rp_parent = parent }
 602   itraverse_ (reParentAddRem rp) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
 603   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 604
 605 reParentNgramsTablePatch :: ReParent NgramsTablePatch
 606 reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
 607   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 608
 609 ------------------------------------------------------------------------
 610
 611 instance Action NgramsTablePatch (Maybe NgramsTableMap) where
 612   act p =
 613     fmap (execState (reParentNgramsTablePatch p)) .
 614     act (p ^. _NgramsTablePatch)
 615
 616 instance Arbitrary NgramsTablePatch where
 617   arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
 618
 619 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
 620 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
 621 -- ntp_ngrams_patches = _NgramsTablePatch .  undefined
 622
 623 type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
 624
 625 ------------------------------------------------------------------------
 626 type Version = Int
 627
 628 data Versioned a = Versioned
 629   { _v_version :: Version
 630   , _v_data    :: a
 631   }
 632   deriving (Generic, Show, Eq)
 633 deriveJSON (unPrefix "_v_") ''Versioned
 634 makeLenses ''Versioned
 635 instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where
 636   declareNamedSchema = wellNamedSchema "_v_"
 637 instance Arbitrary a => Arbitrary (Versioned a) where
 638   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 639
 640 ------------------------------------------------------------------------
 641 data Repo s p = Repo
 642   { _r_version :: !Version
 643   , _r_state   :: !s
 644   , _r_history :: ![p]
 645     -- first patch in the list is the most recent
 646   }
 647   deriving (Generic)
 648
 649 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
 650   parseJSON = genericParseJSON $ unPrefix "_r_"
 651
 652 instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
 653   toJSON     = genericToJSON     $ unPrefix "_r_"
 654   toEncoding = genericToEncoding $ unPrefix "_r_"
 655
 656 instance (Serialise s, Serialise p) => Serialise (Repo s p)
 657
 658 makeLenses ''Repo
 659
 660 initRepo :: Monoid s => Repo s p
 661 initRepo = Repo 1 mempty []
 662
 663 type NgramsRepo       = Repo NgramsState NgramsStatePatch
 664 type NgramsState      = Map      TableNgrams.NgramsType (Map NodeId NgramsTableMap)
 665 type NgramsStatePatch = PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch)
 666
 667 instance Serialise (PM.PatchMap NodeId NgramsTablePatch)
 668 instance Serialise NgramsStatePatch
 669
 670 initMockRepo :: NgramsRepo
 671 initMockRepo = Repo 1 s []
 672   where
 673     s = Map.singleton TableNgrams.NgramsTerms
 674       $ Map.singleton 47254
 675       $ Map.fromList
 676       [ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ]
 677
 678 data RepoEnv = RepoEnv
 679   { _renv_var   :: !(MVar NgramsRepo)
 680   , _renv_saver :: !(IO ())
 681   , _renv_lock  :: !FileLock
 682   }
 683   deriving (Generic)
 684
 685 makeLenses ''RepoEnv
 686
 687 class HasRepoVar env where
 688   repoVar :: Getter env (MVar NgramsRepo)
 689
 690 instance HasRepoVar (MVar NgramsRepo) where
 691   repoVar = identity
 692
 693 class HasRepoSaver env where
 694   repoSaver :: Getter env (IO ())
 695
 696 class (HasRepoVar env, HasRepoSaver env) => HasRepo env where
 697   repoEnv :: Getter env RepoEnv
 698
 699 instance HasRepo RepoEnv where
 700   repoEnv = identity
 701
 702 instance HasRepoVar RepoEnv where
 703   repoVar = renv_var
 704
 705 instance HasRepoSaver RepoEnv where
 706   repoSaver = renv_saver
 707
 708 type RepoCmdM   env err m =
 709   ( CmdM'             env err m
 710   , HasRepo           env
 711   , HasConnectionPool env
 712   , HasConfig         env
 713   )
 714
 715
 716 type QueryParamR = QueryParam' '[Required, Strict]
 717
 718
 719 -- Instances
 720 instance Arbitrary NgramsRepoElement where
 721   arbitrary = elements $ map ngramsElementToRepo ns
 722     where
 723       NgramsTable ns = mockTable
 724
 725 --{-
 726 instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
 727   where
 728     parseUrlPiece x = maybeToEither x (decode $ cs x)
 729
 730
 731 ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
 732 ngramsTypeFromTabType tabType =
 733   let lieu = "Garg.API.Ngrams: " :: Text in
 734     case tabType of
 735       Sources    -> TableNgrams.Sources
 736       Authors    -> TableNgrams.Authors
 737       Institutes -> TableNgrams.Institutes
 738       Terms      -> TableNgrams.NgramsTerms
 739       _          -> panic $ lieu <> "No Ngrams for this tab"
 740       -- TODO: This `panic` would disapear with custom NgramsType.
 741
 742 ----
 743 -- Async task
 744
 745 data UpdateTableNgramsCharts = UpdateTableNgramsCharts
 746   { _utn_tab_type :: !TabType
 747   , _utn_list_id  :: !ListId
 748   } deriving (Eq, Show, Generic)
 749
 750 makeLenses ''UpdateTableNgramsCharts
 751 instance FromJSON UpdateTableNgramsCharts where
 752   parseJSON = genericParseJSON $ jsonOptions "_utn_"
 753 instance ToSchema UpdateTableNgramsCharts where
 754   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_utn_")