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