{-|
Module : Gargantext.API.Ngrams
Description : Server API
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Ngrams API
-- | TODO
get ngrams filtered by NgramsType
add get
-}
{-# LANGUAGE DataKinds #-}
{-# 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 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 (isJust)
import Data.Tuple.Extra (first)
-- import qualified Data.Map.Strict as DM
import Data.Map.Strict (Map, mapKeys, fromListWith)
--import qualified Data.Set as Set
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.Map (lookup)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Swagger hiding (version, patch)
import Data.Text (Text)
import GHC.Generics (Generic)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Types.Node (NodeType(..))
import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
import Gargantext.Database.Schema.Ngrams (NgramsType, NgramsTypeId, ngramsTypeId, NgramsTableData(..))
import qualified Gargantext.Database.Schema.Ngrams as Ngrams
import Gargantext.Database.Schema.NodeNgram
import Gargantext.Database.Utils (Cmd)
import Gargantext.Prelude
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)
------------------------------------------------------------------------
--data FacetFormat = Table | Chart
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 "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
instance FromJSON TabType
instance ToSchema TabType
instance Arbitrary TabType
where
arbitrary = elements [minBound .. maxBound]
------------------------------------------------------------------------
type NgramsTerm = Text
data NgramsElement =
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
makeLenses ''NgramsElement
instance ToSchema NgramsElement
instance Arbitrary NgramsElement where
arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
------------------------------------------------------------------------
newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
-- | TODO Check N and Weight
toNgramsElement :: [NgramsTableData] -> [NgramsElement]
toNgramsElement ns = map toNgramsElement' ns
where
toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
where
p' = case p of
Nothing -> Nothing
Just x -> lookup x mapParent
c' = maybe mempty identity $ lookup t mapChildren
lt' = maybe (panic "API.Ngrams: listypeId") identity lt
mapParent :: Map Int Text
mapParent = fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
mapChildren :: Map Text (Set Text)
mapChildren = mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
$ fromListWith (<>)
$ map (first fromJust)
$ filter (isJust . fst)
$ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
instance Arbitrary NgramsTable where
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
------------------------------------------------------------------------
-- On the Client side:
--data Action = InGroup NgramsId NgramsId
-- | OutGroup NgramsId NgramsId
-- | SetListType NgramsId ListType
data PatchSet a = PatchSet
{ _rem :: Set a
, _add :: Set a
}
deriving (Eq, Ord, Show, Generic)
instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
arbitrary = PatchSet <$> 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 "_"
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
-- instance Semigroup NgramsPatch where
instance ToSchema NgramsPatch
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
-- TODO: replace by mempty once we have the Monoid instance
emptyNgramsTablePatch :: NgramsTablePatch
emptyNgramsTablePatch = NgramsTablePatch mempty
------------------------------------------------------------------------
------------------------------------------------------------------------
type Version = Int
data Versioned a = Versioned
{ _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 NgramsIdPatch = Patch NgramsId NgramsPatch
ngramsPatch :: Int -> NgramsPatch
ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
toEdit n p = Edit n p
ngramsIdPatch :: Patch NgramsId NgramsPatch
ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
, replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
, replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
]
-- applyPatchBack :: Patch -> IO Patch
-- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
-}
------------------------------------------------------------------------
------------------------------------------------------------------------
------------------------------------------------------------------------
type TableNgramsApiGet = Summary " Table Ngrams API Get"
:> QueryParam "ngramsType" TabType
:> QueryParam "list" ListId
:> QueryParam "limit" Limit
:> QueryParam "offset" Offset
:> Get '[JSON] (Versioned NgramsTable)
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 :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
mkListsUpdate nt patches =
[ (ngramsTypeId nt, ng, listTypeId lt)
| (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
, lt <- patch ^.. patch_list . new
]
mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm)
-> NgramsType
-> NgramsTablePatch
-> [(NgramsTypeId, NgramsParent, NgramsChild)]
mkChildrenGroups addOrRem nt patches =
[ (ngramsTypeId nt, parent, child)
| (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 -> 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_user_list_id = listId
, _nnu_lists_update = mkListsUpdate ngramsType patch
, _nnu_rem_children = mkChildrenGroups _rem ngramsType patch
, _nnu_add_children = mkChildrenGroups _add ngramsType 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 ngramsType = ngramsTypeFromTabType maybeTabType
listId <- maybe (defaultList cId) pure maybeListId
let
defaultLimit = 10 -- TODO
limit_ = maybe defaultLimit identity mlimit
offset_ = maybe 0 identity moffset
ngramsTableDatas <-
Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
-- printDebug "ngramsTableDatas" ngramsTableDatas
pure $ Versioned 1 $ NgramsTable (toNgramsElement ngramsTableDatas)