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 System.FileLock (FileLock)
  42 import Test.QuickCheck (elements, frequency)
  43 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  44
  45 import Protolude (maybeToEither)
  46 import Gargantext.Prelude
  47
  48 import Gargantext.Core.Text (size)
  49 import Gargantext.Core.Types (ListType(..), NodeId)
  50 import Gargantext.Core.Types (TODO)
  51 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger, wellNamedSchema)
  52 import Gargantext.Database.Prelude (fromField', CmdM')
  53 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
  54
  55 ------------------------------------------------------------------------
  56 --data FacetFormat = Table | Chart
  57 data TabType   = Docs   | Trash   | MoreFav | MoreTrash
  58                | Terms  | Sources | Authors | Institutes
  59                | Contacts
  60   deriving (Bounded, Enum, Eq, Generic, Ord, Show)
  61
  62 instance FromHttpApiData TabType
  63    where
  64     parseUrlPiece "Docs"       = pure Docs
  65     parseUrlPiece "Trash"      = pure Trash
  66     parseUrlPiece "MoreFav"    = pure MoreFav
  67     parseUrlPiece "MoreTrash"  = pure MoreTrash
  68
  69     parseUrlPiece "Terms"      = pure Terms
  70     parseUrlPiece "Sources"    = pure Sources
  71     parseUrlPiece "Institutes" = pure Institutes
  72     parseUrlPiece "Authors"    = pure Authors
  73
  74     parseUrlPiece "Contacts"   = pure Contacts
  75
  76     parseUrlPiece _            = Left "Unexpected value of TabType"
  77 instance ToParamSchema TabType
  78 instance ToJSON        TabType
  79 instance FromJSON      TabType
  80 instance ToSchema      TabType
  81 instance Arbitrary     TabType
  82   where
  83     arbitrary = elements [minBound .. maxBound]
  84 instance FromJSONKey TabType where
  85   fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
  86 instance ToJSONKey TabType where
  87   toJSONKey = genericToJSONKey defaultJSONKeyOptions
  88
  89 newtype MSet a = MSet (Map a ())
  90   deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
  91
  92 instance ToJSON a => ToJSON (MSet a) where
  93   toJSON     (MSet m) = toJSON     (Map.keys m)
  94   toEncoding (MSet m) = toEncoding (Map.keys m)
  95
  96 mSetFromSet :: Set a -> MSet a
  97 mSetFromSet = MSet . Map.fromSet (const ())
  98
  99 mSetFromList :: Ord a => [a] -> MSet a
 100 mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
 101
 102 -- mSetToSet :: Ord a => MSet a -> Set a
 103 -- mSetToSet (MSet a) = Set.fromList ( Map.keys a)
 104 mSetToSet :: Ord a => MSet a -> Set a
 105 mSetToSet = Set.fromList . mSetToList
 106
 107 mSetToList :: MSet a -> [a]
 108 mSetToList (MSet a) = Map.keys a
 109
 110 instance Foldable MSet where
 111   foldMap f (MSet m) = Map.foldMapWithKey (\k _ -> f k) m
 112
 113 instance (Ord a, FromJSON a) => FromJSON (MSet a) where
 114   parseJSON = fmap mSetFromList . parseJSON
 115
 116 instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
 117   -- TODO
 118   declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
 119
 120 ------------------------------------------------------------------------
 121 newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text }
 122   deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema)
 123
 124 instance FromJSONKey NgramsTerm where
 125   fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t
 126
 127 instance IsString NgramsTerm where
 128   fromString s = NgramsTerm $ pack s
 129
 130 instance FromField NgramsTerm
 131   where
 132     fromField field mb = do
 133       v <- fromField field mb
 134       case fromJSON v of
 135         Success a -> pure $ NgramsTerm $ strip a
 136         Error _err -> returnError ConversionFailed field
 137                       $ List.intercalate " " [ "cannot parse hyperdata for JSON: "
 138                                              , show v
 139                                              ]
 140
 141 data RootParent = RootParent
 142   { _rp_root   :: NgramsTerm
 143   , _rp_parent :: NgramsTerm
 144   }
 145   deriving (Ord, Eq, Show, Generic)
 146
 147 deriveJSON (unPrefix "_rp_") ''RootParent
 148 makeLenses ''RootParent
 149
 150 data NgramsRepoElement = NgramsRepoElement
 151   { _nre_size        :: Int
 152   , _nre_list        :: ListType
 153 --, _nre_root_parent :: Maybe RootParent
 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   )
 712
 713
 714 type QueryParamR = QueryParam' '[Required, Strict]
 715
 716
 717 -- Instances
 718 instance Arbitrary NgramsRepoElement where
 719   arbitrary = elements $ map ngramsElementToRepo ns
 720     where
 721       NgramsTable ns = mockTable
 722
 723 --{-
 724 instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
 725   where
 726     parseUrlPiece x = maybeToEither x (decode $ cs x)
 727
 728
 729 ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
 730 ngramsTypeFromTabType tabType =
 731   let lieu = "Garg.API.Ngrams: " :: Text in
 732     case tabType of
 733       Sources    -> TableNgrams.Sources
 734       Authors    -> TableNgrams.Authors
 735       Institutes -> TableNgrams.Institutes
 736       Terms      -> TableNgrams.NgramsTerms
 737       _          -> panic $ lieu <> "No Ngrams for this tab"
 738       -- TODO: This `panic` would disapear with custom NgramsType.