src/Gargantext/API/Ngrams/Types.hs

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