Ngrams API
-- | TODO
--- get data of NgramsTable
--- post :: update NodeNodeNgrams
--- group ngrams
-
get ngrams filtered by NgramsType
add get
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# OPTIONS -fno-warn-orphans #-}
module Gargantext.API.Ngrams
where
--- import Gargantext.Database.User (UserId)
---import Data.Map.Strict.Patch (Patch, replace, fromList)
+import Prelude (round)
+-- import Gargantext.Database.Schema.User (UserId)
+import Data.Functor (($>))
+import Data.Patch.Class (Replace, replace, new)
+--import qualified Data.Map.Strict.Patch as PM
+import Data.Monoid
+--import Data.Semigroup
+import Data.Set (Set)
+import qualified Data.Set as Set
--import Data.Maybe (catMaybes)
---import qualified Data.Map.Strict as DM
+-- import qualified Data.Map.Strict as DM
+import Data.Map.Strict (Map)
--import qualified Data.Set as Set
-import Control.Lens (view)
-import Data.Aeson (FromJSON, ToJSON)
+import Control.Lens (makeLenses, Prism', prism', (^..), (.~), (#), to, withIndex, folded, ifolded)
+import Control.Monad (guard)
+import Control.Monad.Error.Class (MonadError, throwError)
+import Data.Aeson
import Data.Aeson.TH (deriveJSON)
import Data.Either(Either(Left))
-import Data.List (concat)
-import Data.Set (Set)
-import Data.Swagger (ToSchema, ToParamSchema)
+import Data.Map (lookup)
+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
+import Data.Swagger hiding (version, patch)
import Data.Text (Text)
-import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic)
-import Gargantext.Core.Types (node_id)
-import Gargantext.Core.Types.Main (Tree(..))
import Gargantext.Core.Utils.Prefix (unPrefix)
-import Gargantext.Database.Ngrams (NgramsId)
-import Gargantext.Database.Node (getListsWithParentId)
--- import Gargantext.Database.NodeNgram -- (NodeNgram(..), NodeNgram, updateNodeNgrams, NodeNgramPoly)
-import Gargantext.Database.NodeNgramsNgrams -- (NodeNgramsNgramsPoly(NodeNgramsNgrams))
+import Gargantext.Database.Types.Node (NodeType(..))
+import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
+import Gargantext.Database.Schema.Ngrams (NgramsType, NgramsTypeId, ngramsTypeId)
+import qualified Gargantext.Database.Schema.Ngrams as Ngrams
+import Gargantext.Database.Schema.NodeNgram
+import Gargantext.Database.Schema.NodeNgramsNgrams
+import Gargantext.Database.Utils (Cmd)
import Gargantext.Prelude
-import Gargantext.Text.List.Types (ListType(..), ListId, ListTypeId) --,listTypeId )
+import Gargantext.Core.Types (ListType(..), ListTypeId, ListId, CorpusId, Limit, Offset, listTypeId)
import Prelude (Enum, Bounded, minBound, maxBound)
import Servant hiding (Patch)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
--- import qualified Data.Set as Set
------------------------------------------------------------------------
--data FacetFormat = Table | Chart
-data TabType = Docs | Terms | Sources | Authors | Trash
+data TabType = Docs | Terms | Sources | Authors | Institutes | Trash
+ | Contacts
deriving (Generic, Enum, Bounded)
instance FromHttpApiData TabType
where
- parseUrlPiece "Docs" = pure Docs
- parseUrlPiece "Terms" = pure Terms
- parseUrlPiece "Sources" = pure Sources
- parseUrlPiece "Authors" = pure Authors
- parseUrlPiece "Trash" = pure Trash
- parseUrlPiece _ = Left "Unexpected value of TabType"
+ parseUrlPiece "Docs" = pure Docs
+ parseUrlPiece "Terms" = pure Terms
+ parseUrlPiece "Sources" = pure Sources
+ parseUrlPiece "Institutes" = pure Institutes
+ parseUrlPiece "Authors" = pure Authors
+ parseUrlPiece "Trash" = pure Trash
+
+ parseUrlPiece "Contacts" = pure Contacts
+
+ parseUrlPiece _ = Left "Unexpected value of TabType"
instance ToParamSchema TabType
instance ToJSON TabType
arbitrary = elements [minBound .. maxBound]
------------------------------------------------------------------------
+type NgramsTerm = Text
+
data NgramsElement =
- NgramsElement { _ne_ngrams :: Text
+ NgramsElement { _ne_ngrams :: NgramsTerm
, _ne_list :: ListType
, _ne_occurrences :: Int
+ , _ne_parent :: Maybe NgramsTerm
+ , _ne_children :: Set NgramsTerm
}
deriving (Ord, Eq, Show, Generic)
-$(deriveJSON (unPrefix "_ne_") ''NgramsElement)
+
+deriveJSON (unPrefix "_ne_") ''NgramsElement
+makeLenses ''NgramsElement
instance ToSchema NgramsElement
instance Arbitrary NgramsElement where
- arbitrary = elements [NgramsElement "sport" StopList 1]
+ arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
------------------------------------------------------------------------
-data NgramsTable = NgramsTable { _ngramsTable :: [Tree NgramsElement] }
- deriving (Ord, Eq, Generic)
-$(deriveJSON (unPrefix "_") ''NgramsTable)
+newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
+ deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
instance Arbitrary NgramsTable where
- arbitrary = NgramsTable <$> arbitrary
-
--- TODO
-instance Arbitrary (Tree NgramsElement) where
- arbitrary = elements [ TreeN (NgramsElement "animal" GraphList 1)
- [TreeN (NgramsElement "dog" GraphList 3) []
- , TreeN (NgramsElement "object" CandidateList 2) []
- , TreeN (NgramsElement "cat" GraphList 1) []
- , TreeN (NgramsElement "nothing" StopList 4) []
- ]
- , TreeN (NgramsElement "plant" GraphList 3)
- [TreeN (NgramsElement "flower" GraphList 3) []
- , TreeN (NgramsElement "moon" CandidateList 1) []
- , TreeN (NgramsElement "cat" GraphList 2) []
- , TreeN (NgramsElement "sky" StopList 1) []
- ]
- ]
+ arbitrary = elements
+ [ NgramsTable
+ [ NgramsElement "animal" GraphList 1 Nothing (Set.fromList ["dog", "cat"])
+ , NgramsElement "cat" GraphList 1 (Just "animal") mempty
+ , NgramsElement "cats" StopList 4 Nothing mempty
+ , NgramsElement "dog" GraphList 3 (Just "animal")(Set.fromList ["dogs"])
+ , NgramsElement "dogs" StopList 4 (Just "dog") mempty
+ , NgramsElement "fox" GraphList 1 Nothing mempty
+ , NgramsElement "object" CandidateList 2 Nothing mempty
+ , NgramsElement "nothing" StopList 4 Nothing mempty
+ , NgramsElement "organic" GraphList 3 Nothing (Set.singleton "flower")
+ , NgramsElement "flower" GraphList 3 (Just "organic") mempty
+ , NgramsElement "moon" CandidateList 1 Nothing mempty
+ , NgramsElement "sky" StopList 1 Nothing mempty
+ ]
+ ]
instance ToSchema NgramsTable
------------------------------------------------------------------------
-- | OutGroup NgramsId NgramsId
-- | SetListType NgramsId ListType
-data NgramsPatch =
- NgramsPatch { _np_list_types :: ListType -- TODO Map UserId ListType
- , _np_add_children :: Set NgramsElement
- , _np_rem_children :: Set NgramsElement
- }
- deriving (Ord, Eq, Show, Generic)
-$(deriveJSON (unPrefix "_np_") ''NgramsPatch)
+data PatchSet a = PatchSet
+ { _rem :: Set a
+ , _add :: Set a
+ }
+ deriving (Eq, Ord, Show, Generic)
-instance ToSchema NgramsPatch
+instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
+ arbitrary = PatchSet <$> arbitrary <*> arbitrary
-instance Arbitrary NgramsPatch where
- arbitrary = NgramsPatch <$> arbitrary <*> arbitrary <*> arbitrary
+instance ToJSON a => ToJSON (PatchSet a) where
+ toJSON = genericToJSON $ unPrefix "_"
+ toEncoding = genericToEncoding $ unPrefix "_"
- --
+instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
+ parseJSON = genericParseJSON $ unPrefix "_"
-data NgramsIdPatch =
- NgramsIdPatch { _nip_ngramsId :: NgramsElement
- , _nip_ngramsPatch :: NgramsPatch
- }
+instance ToSchema a => ToSchema (PatchSet a)
+
+instance ToSchema a => ToSchema (Replace a) where
+ declareNamedSchema (_ :: proxy (Replace a)) = do
+ -- TODO Keep constructor is not supported here.
+ aSchema <- declareSchemaRef (Proxy :: Proxy a)
+ return $ NamedSchema (Just "Replace") $ mempty
+ & type_ .~ SwaggerObject
+ & properties .~
+ InsOrdHashMap.fromList
+ [ ("old", aSchema)
+ , ("new", aSchema)
+ ]
+ & required .~ [ "old", "new" ]
+
+data NgramsPatch =
+ NgramsPatch { _patch_children :: PatchSet NgramsTerm
+ , _patch_list :: Replace ListType -- TODO Map UserId ListType
+ }
deriving (Ord, Eq, Show, Generic)
+deriveJSON (unPrefix "_") ''NgramsPatch
+makeLenses ''NgramsPatch
-$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
+-- instance Semigroup NgramsPatch where
-instance ToSchema NgramsIdPatch
+instance ToSchema NgramsPatch
-instance Arbitrary NgramsIdPatch where
- arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
+instance Arbitrary NgramsPatch where
+ arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
- --
+newtype NgramsTablePatch =
+ NgramsTablePatch { _ntp_ngrams_patches :: Map NgramsTerm NgramsPatch }
+ deriving (Ord, Eq, Show, Generic, Arbitrary, ToJSON, FromJSON)
+makeLenses ''NgramsTablePatch
+instance ToSchema NgramsTablePatch
-data NgramsIdPatchs =
- NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
- deriving (Ord, Eq, Show, Generic)
-$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
-instance ToSchema NgramsIdPatchs
-instance Arbitrary NgramsIdPatchs where
- arbitrary = NgramsIdPatchs <$> arbitrary
+-- TODO: replace by mempty once we have the Monoid instance
+emptyNgramsTablePatch :: NgramsTablePatch
+emptyNgramsTablePatch = NgramsTablePatch mempty
------------------------------------------------------------------------
------------------------------------------------------------------------
{ _v_version :: Version
, _v_data :: a
}
-
+ deriving (Generic)
+deriveJSON (unPrefix "_v_") ''Versioned
+makeLenses ''Versioned
+instance ToSchema a => ToSchema (Versioned a)
+instance Arbitrary a => Arbitrary (Versioned a) where
+ arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
{-
-- TODO sequencs of modifications (Patchs)
------------------------------------------------------------------------
------------------------------------------------------------------------
------------------------------------------------------------------------
-type CorpusId = Int
-type TableNgramsApi = Summary " Table Ngrams API Change"
- :> QueryParam "list" ListId
- :> ReqBody '[JSON] NgramsIdPatchs
- :> Put '[JSON] NgramsIdPatchsBack
type TableNgramsApiGet = Summary " Table Ngrams API Get"
:> QueryParam "ngramsType" TabType
:> QueryParam "list" ListId
- :> Get '[JSON] NgramsTable
-
-type NgramsIdPatchsFeed = NgramsIdPatchs
-type NgramsIdPatchsBack = NgramsIdPatchs
-
-
-defaultList :: Connection -> CorpusId -> IO ListId
-defaultList c cId = view node_id <$> maybe (panic noListFound) identity
- <$> head
- <$> getListsWithParentId c cId
- where
- noListFound = "Gargantext.API.Ngrams.defaultList: no list found"
-
-toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
-toLists lId np = map (toList lId) (_nip_ngramsIdPatchs np)
+ :> QueryParam "limit" Limit
+ :> QueryParam "offset" Offset
+ :> Get '[JSON] (Versioned NgramsTable)
-toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
-toList = undefined
--- toList lId (NgramsIdPatch ngId (NgramsPatch lt _ _)) = (lId,ngId,listTypeId lt)
-
-toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
-toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
-
-toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
-toGroup = undefined
-{-
-toGroup lId addOrRem (NgramsIdPatch ngId patch) =
- map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
--}
+type TableNgramsApi = Summary " Table Ngrams API Change"
+ :> QueryParam "ngramsType" TabType
+ :> QueryParam "list" ListId
+ :> ReqBody '[JSON] (Versioned NgramsTablePatch)
+ :> Put '[JSON] (Versioned NgramsTablePatch)
+
+data NgramError = UnsupportedVersion
+ deriving (Show)
+
+class HasNgramError e where
+ _NgramError :: Prism' e NgramError
+
+instance HasNgramError ServantErr where
+ _NgramError = prism' make match
+ where
+ err = err500 { errBody = "NgramError: Unsupported version" }
+ make UnsupportedVersion = err
+ match e = guard (e == err) $> UnsupportedVersion
+
+ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
+ngramError nne = throwError $ _NgramError # nne
+
+-- TODO: Replace.old is ignored which means that if the current list
+-- `GraphList` and that the patch is `Replace CandidateList StopList` then
+-- the list is going to be `StopList` while it should keep `GraphList`.
+-- However this should not happen in non conflicting situations.
+mkListsUpdate :: ListId -> NgramsType -> NgramsTablePatch -> [(ListId, NgramsTypeId, NgramsTerm, ListTypeId)]
+mkListsUpdate lId nt patches =
+ [ (lId, ngramsTypeId nt, ng, listTypeId lt)
+ | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
+ , lt <- patch ^.. patch_list . new
+ ]
+
+mkChildrenGroups :: ListId
+ -> (PatchSet NgramsTerm -> Set NgramsTerm)
+ -> NgramsTablePatch
+ -> [(ListId, NgramsParent, NgramsChild, Maybe Double)]
+mkChildrenGroups lId addOrRem patches =
+ [ (lId, parent, child, Just 1)
+ | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
+ , child <- patch ^.. patch_children . to addOrRem . folded
+ ]
+
+ngramsTypeFromTabType :: Maybe TabType -> NgramsType
+ngramsTypeFromTabType maybeTabType =
+ let lieu = "Garg.API.Ngrams: " :: Text in
+ case maybeTabType of
+ Nothing -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
+ Just tab -> case tab of
+ Sources -> Ngrams.Sources
+ Authors -> Ngrams.Authors
+ Institutes -> Ngrams.Institutes
+ Terms -> Ngrams.NgramsTerms
+ _ -> panic $ lieu <> "No Ngrams for this tab"
+
+
+-- Apply the given patch to the DB and returns the patch to be applied on the
+-- cilent.
+-- TODO:
+-- In this perliminary version the OT aspect is missing, therefore the version
+-- number is always 1 and the returned patch is always empty.
+tableNgramsPatch :: (HasNgramError err, HasNodeError err)
+ => CorpusId -> Maybe TabType -> Maybe ListId
+ -> Versioned NgramsTablePatch
+ -> Cmd err (Versioned NgramsTablePatch)
+tableNgramsPatch corpusId maybeTabType maybeList (Versioned version patch) = do
+ when (version /= 1) $ ngramError UnsupportedVersion
+ let ngramsType = ngramsTypeFromTabType maybeTabType
+ listId <- maybe (defaultList corpusId) pure maybeList
+ updateNodeNgrams $ NodeNgramsUpdate
+ { _nnu_lists_update = mkListsUpdate listId ngramsType patch
+ , _nnu_rem_children = mkChildrenGroups listId _rem patch
+ , _nnu_add_children = mkChildrenGroups listId _add patch
+ }
+ pure $ Versioned 1 emptyNgramsTablePatch
+
+-- | TODO Errors management
+-- TODO: polymorphic for Annuaire or Corpus or ...
+getTableNgrams :: HasNodeError err
+ => CorpusId -> Maybe TabType
+ -> Maybe ListId -> Maybe Limit -> Maybe Offset
+ -> Cmd err (Versioned NgramsTable)
+getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
+ let lieu = "Garg.API.Ngrams: " :: Text
+ let ngramsType = ngramsTypeFromTabType maybeTabType
+ listId <- maybe (defaultList cId) pure maybeListId
+
+ let
+ defaultLimit = 10 -- TODO
+ limit_ = maybe defaultLimit identity mlimit
+ offset_ = maybe 0 identity moffset
+
+ (ngramsTableDatas, mapToParent, mapToChildren) <-
+ Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
+
+ -- printDebug "ngramsTableDatas" ngramsTableDatas
+
+ pure $ Versioned 1 $
+ NgramsTable $ map (\(Ngrams.NgramsTableData ngs _ lt w) ->
+ NgramsElement ngs
+ (maybe (panic $ lieu <> "listType") identity lt)
+ (round w)
+ (lookup ngs mapToParent)
+ (maybe mempty identity $ lookup ngs mapToChildren)
+ ) ngramsTableDatas
-tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
-tableNgramsPatch = undefined
-{-
-tableNgramsPatch conn corpusId maybeList patchs = do
- listId <- case maybeList of
- Nothing -> defaultList conn corpusId
- Just listId' -> pure listId'
- _ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
- _ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
- _ <- updateNodeNgrams conn (toLists listId patchs)
- pure (NgramsIdPatchs [])
- -}
-
-getTableNgramsPatch :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
-getTableNgramsPatch = undefined