src/Gargantext/API/Ngrams.hs

   1 {-|
   2 Module      : Gargantext.API.Ngrams
   3 Description : Server API
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Ngrams API
  11
  12 -- | TODO
  13 -- get data of NgramsTable
  14 -- post :: update NodeNodeNgrams
  15 -- group ngrams
  16
  17 get ngrams filtered by NgramsType
  18 add get
  19
  20 -}
  21
  22 {-# LANGUAGE DataKinds         #-}
  23 {-# LANGUAGE DeriveGeneric     #-}
  24 {-# LANGUAGE NoImplicitPrelude #-}
  25 {-# LANGUAGE OverloadedStrings #-}
  26 {-# LANGUAGE ScopedTypeVariables #-}
  27 {-# LANGUAGE TemplateHaskell   #-}
  28 {-# LANGUAGE TypeOperators     #-}
  29 {-# LANGUAGE FlexibleInstances #-}
  30 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  31 {-# LANGUAGE RankNTypes        #-}
  32 {-# OPTIONS -fno-warn-orphans #-}
  33
  34 module Gargantext.API.Ngrams
  35   where
  36
  37 import Prelude (round)
  38 -- import Gargantext.Database.Schema.User  (UserId)
  39 import Data.Functor (($>))
  40 import Data.Patch.Class (Replace, replace)
  41 --import qualified Data.Map.Strict.Patch as PM
  42 import Data.Monoid
  43 --import Data.Semigroup
  44 import Data.Set (Set)
  45 import qualified Data.Set as Set
  46 --import Data.Maybe (catMaybes)
  47 -- import qualified Data.Map.Strict as DM
  48 import Data.Map.Strict (Map)
  49 --import qualified Data.Set as Set
  50 import Control.Lens (Prism', prism', (.~), (#))
  51 import Control.Monad (guard)
  52 import Control.Monad.Error.Class (MonadError, throwError)
  53 import Data.Aeson
  54 import Data.Aeson.TH (deriveJSON)
  55 import Data.Either(Either(Left))
  56 import Data.Map (lookup)
  57 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
  58 import Data.Swagger hiding (version)
  59 import Data.Text (Text)
  60 import GHC.Generics (Generic)
  61 --import Gargantext.Core.Types.Main (Tree(..))
  62 import Gargantext.Core.Utils.Prefix (unPrefix)
  63 import Gargantext.Database.Types.Node (NodeType(..))
  64 import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
  65 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
  66 import Gargantext.Database.Utils (Cmd)
  67 import Gargantext.Prelude
  68 import Gargantext.Core.Types (ListType(..), ListId, CorpusId, Limit, Offset)
  69 import Prelude (Enum, Bounded, minBound, maxBound)
  70 import Servant hiding (Patch)
  71 import Test.QuickCheck (elements)
  72 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  73
  74 ------------------------------------------------------------------------
  75 --data FacetFormat = Table | Chart
  76 data TabType   = Docs     | Terms  | Sources | Authors | Institutes | Trash
  77                | Contacts
  78   deriving (Generic, Enum, Bounded)
  79
  80 instance FromHttpApiData TabType
  81   where
  82     parseUrlPiece "Docs"       = pure Docs
  83     parseUrlPiece "Terms"      = pure Terms
  84     parseUrlPiece "Sources"    = pure Sources
  85     parseUrlPiece "Institutes" = pure Institutes
  86     parseUrlPiece "Authors"    = pure Authors
  87     parseUrlPiece "Trash"      = pure Trash
  88
  89     parseUrlPiece "Contacts"   = pure Contacts
  90
  91     parseUrlPiece _            = Left "Unexpected value of TabType"
  92
  93 instance ToParamSchema   TabType
  94 instance ToJSON    TabType
  95 instance FromJSON  TabType
  96 instance ToSchema  TabType
  97 instance Arbitrary TabType
  98   where
  99     arbitrary = elements [minBound .. maxBound]
 100
 101 ------------------------------------------------------------------------
 102 type NgramsTerm = Text
 103
 104 data NgramsElement =
 105      NgramsElement { _ne_ngrams      :: NgramsTerm
 106                    , _ne_list        :: ListType
 107                    , _ne_occurrences :: Int
 108                    , _ne_parent      :: Maybe NgramsTerm
 109                    , _ne_children    :: Set NgramsTerm
 110                    }
 111       deriving (Ord, Eq, Show, Generic)
 112 $(deriveJSON (unPrefix "_ne_") ''NgramsElement)
 113
 114 instance ToSchema NgramsElement
 115 instance Arbitrary NgramsElement where
 116   arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
 117
 118 ------------------------------------------------------------------------
 119 newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
 120   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 121
 122 instance Arbitrary NgramsTable where
 123   arbitrary = elements
 124               [ NgramsTable
 125                 [ NgramsElement "animal"  GraphList     1  Nothing       (Set.fromList ["dog", "cat"])
 126                 , NgramsElement "cat"     GraphList     1 (Just "animal") mempty
 127                 , NgramsElement "cats"    StopList      4  Nothing        mempty
 128                 , NgramsElement "dog"     GraphList     3 (Just "animal")(Set.fromList ["dogs"])
 129                 , NgramsElement "dogs"    StopList      4 (Just "dog")    mempty
 130                 , NgramsElement "fox"     GraphList     1  Nothing        mempty
 131                 , NgramsElement "object"  CandidateList 2  Nothing        mempty
 132                 , NgramsElement "nothing" StopList      4  Nothing        mempty
 133                 , NgramsElement "organic" GraphList     3  Nothing        (Set.singleton "flower")
 134                 , NgramsElement "flower"  GraphList     3 (Just "organic") mempty
 135                 , NgramsElement "moon"    CandidateList 1  Nothing         mempty
 136                 , NgramsElement "sky"     StopList      1  Nothing         mempty
 137                 ]
 138               ]
 139 instance ToSchema NgramsTable
 140
 141 ------------------------------------------------------------------------
 142 -- On the Client side:
 143 --data Action = InGroup     NgramsId NgramsId
 144 --            | OutGroup    NgramsId NgramsId
 145 --            | SetListType NgramsId ListType
 146
 147 data PatchSet a = PatchSet
 148   { _rem :: Set a
 149   , _add :: Set a
 150   }
 151   deriving (Eq, Ord, Show, Generic)
 152
 153 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 154   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 155
 156 instance ToJSON a => ToJSON (PatchSet a) where
 157   toJSON     = genericToJSON     $ unPrefix "_"
 158   toEncoding = genericToEncoding $ unPrefix "_"
 159
 160 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
 161   parseJSON = genericParseJSON $ unPrefix "_"
 162
 163 instance ToSchema a => ToSchema (PatchSet a)
 164
 165 instance ToSchema a => ToSchema (Replace a) where
 166   declareNamedSchema (_ :: proxy (Replace a)) = do
 167     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 168     return $ NamedSchema (Just "Replace") $ mempty
 169       & type_ .~ SwaggerObject
 170       & properties .~
 171           InsOrdHashMap.fromList
 172           [ ("old", aSchema)
 173           , ("new", aSchema)
 174           ]
 175       & required .~ [ "old", "new" ]
 176
 177 data NgramsPatch =
 178      NgramsPatch { _patch_children :: PatchSet NgramsElement
 179                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
 180                  }
 181       deriving (Ord, Eq, Show, Generic)
 182 $(deriveJSON (unPrefix "_") ''NgramsPatch)
 183
 184 -- instance Semigroup NgramsPatch where
 185
 186 instance ToSchema  NgramsPatch
 187
 188 instance Arbitrary NgramsPatch where
 189   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 190
 191 -- TODO:
 192 -- * This should be a Map NgramsId NgramsPatch
 193 -- * Patchs -> Patches
 194 newtype NgramsTablePatch =
 195      NgramsTablePatch { _nip_ngramsIdPatchs :: Map NgramsTerm NgramsPatch }
 196       deriving (Ord, Eq, Show, Generic, Arbitrary)
 197 $(deriveJSON (unPrefix "_nip_") ''NgramsTablePatch)
 198 instance ToSchema  NgramsTablePatch
 199
 200 -- TODO: replace by mempty once we have the Monoid instance
 201 emptyNgramsTablePatch :: NgramsTablePatch
 202 emptyNgramsTablePatch = NgramsTablePatch mempty
 203
 204 ------------------------------------------------------------------------
 205 ------------------------------------------------------------------------
 206 type Version = Int
 207
 208 data Versioned a = Versioned
 209   { _v_version :: Version
 210   , _v_data    :: a
 211   }
 212
 213 {-
 214 -- TODO sequencs of modifications (Patchs)
 215 type NgramsIdPatch = Patch NgramsId NgramsPatch
 216
 217 ngramsPatch :: Int -> NgramsPatch
 218 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 219
 220 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 221 toEdit n p = Edit n p
 222 ngramsIdPatch :: Patch NgramsId NgramsPatch
 223 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 224                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 225                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 226                                        ]
 227
 228 -- applyPatchBack :: Patch -> IO Patch
 229 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 230 -}
 231 ------------------------------------------------------------------------
 232 ------------------------------------------------------------------------
 233 ------------------------------------------------------------------------
 234
 235 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 236                       :> QueryParam "ngramsType"   TabType
 237                       :> QueryParam "list"   ListId
 238                       :> QueryParam "limit"  Limit
 239                       :> QueryParam "offset" Offset
 240                       :> Get    '[JSON] NgramsTable
 241
 242 type TableNgramsApi = Summary " Table Ngrams API Change"
 243                       :> QueryParam "list"   ListId
 244                       :> ReqBody '[JSON] NgramsTablePatch -- (Versioned NgramsTablePatch)
 245                       :> Put     '[JSON] NgramsTablePatch -- (Versioned NgramsTablePatch)
 246
 247 data NgramError = UnsupportedVersion
 248   deriving (Show)
 249
 250 class HasNgramError e where
 251   _NgramError :: Prism' e NgramError
 252
 253 instance HasNgramError ServantErr where
 254   _NgramError = prism' make match
 255     where
 256       err = err500 { errBody = "NgramError: Unsupported version" }
 257       make UnsupportedVersion = err
 258       match e = guard (e == err) $> UnsupportedVersion
 259
 260 ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
 261 ngramError nne = throwError $ _NgramError # nne
 262
 263 {-
 264 toLists :: ListId -> NgramsTablePatch -> [(ListId, NgramsId, ListTypeId)]
 265 -- toLists = undefined
 266 toLists lId np = [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
 267
 268 toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
 269 toList = undefined
 270
 271 toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsTablePatch -> [NodeNgramsNgrams]
 272 toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
 273
 274 toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
 275 -- toGroup = undefined
 276 toGroup lId addOrRem (NgramsIdPatch ngId patch)  =
 277   map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
 278
 279 -}
 280
 281 -- Apply the given patch to the DB and returns the patch to be applied on the
 282 -- cilent.
 283 -- TODO:
 284 -- In this perliminary version the OT aspect is missing, therefore the version
 285 -- number is always 1 and the returned patch is always empty.
 286 tableNgramsPatch :: (HasNgramError err, HasNodeError err)
 287                  => CorpusId -> Maybe ListId
 288                  -- -> Versioned NgramsTablePatch
 289                  -- -> Cmd err (Versioned NgramsTablePatch)
 290                  -> any
 291                  -> Cmd err any
 292 tableNgramsPatch _ _ _ = undefined
 293 {-
 294 tableNgramsPatch corpusId maybeList (Versioned version _patch) = do
 295   when (version /= 1) $ ngramError UnsupportedVersion
 296   _listId <- maybe (defaultList corpusId) pure maybeList
 297 {-
 298   _ <- ngramsGroup' Add $ toGroups listId _np_add_children patch
 299   _ <- ngramsGroup' Del $ toGroups listId _np_rem_children patch
 300   _ <- updateNodeNgrams (toLists listId patch)
 301 -}
 302   pure $ Versioned 1 emptyNgramsTablePatch
 303 -}
 304
 305 -- | TODO Errors management
 306 --  TODO: polymorphic for Annuaire or Corpus or ...
 307 getTableNgrams :: HasNodeError err
 308                => CorpusId -> Maybe TabType
 309                -> Maybe ListId -> Maybe Limit -> Maybe Offset
 310                -> Cmd err NgramsTable
 311 getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
 312   let lieu = "Garg.API.Ngrams: " :: Text
 313   let ngramsType = case maybeTabType of
 314         Nothing  -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
 315         Just tab -> case tab of
 316             Sources    -> Ngrams.Sources
 317             Authors    -> Ngrams.Authors
 318             Institutes -> Ngrams.Institutes
 319             Terms      -> Ngrams.NgramsTerms
 320             _          -> panic $ lieu <> "No Ngrams for this tab"
 321
 322   listId <- maybe (defaultList cId) pure maybeListId
 323
 324   let
 325     defaultLimit = 10 -- TODO
 326     limit_  = maybe defaultLimit identity mlimit
 327     offset_ = maybe 0 identity moffset
 328
 329   (ngramsTableDatas, mapToParent, mapToChildren) <-
 330     Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
 331
 332   -- printDebug "ngramsTableDatas" ngramsTableDatas
 333
 334   pure $ NgramsTable $ map (\(Ngrams.NgramsTableData ngs _ lt w) ->
 335                               NgramsElement ngs
 336                                             (maybe (panic $ lieu <> "listType") identity lt)
 337                                             (round w)
 338                                             (lookup ngs mapToParent)
 339                                             (maybe mempty identity $ lookup ngs mapToChildren)
 340                            ) ngramsTableDatas
 341
 342