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