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 {-# OPTIONS -fno-warn-orphans #-}
  32
  33 module Gargantext.API.Ngrams
  34   where
  35
  36 import Prelude (round)
  37 -- import Gargantext.Database.User  (UserId)
  38 import Data.Patch.Class (Replace, replace)
  39 --import qualified Data.Map.Strict.Patch as PM
  40 import Data.Monoid
  41 --import Data.Semigroup
  42 import Data.Set (Set)
  43 import qualified Data.Set as Set
  44 --import Data.Maybe (catMaybes)
  45 --import qualified Data.Map.Strict as DM
  46 --import qualified Data.Set as Set
  47 import Control.Lens ((.~))
  48 import Data.Aeson
  49 import Data.Aeson.TH (deriveJSON)
  50 import Data.Either(Either(Left))
  51 import Data.Map (lookup)
  52 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
  53 import Data.Swagger
  54 import Data.Text (Text)
  55 import Database.PostgreSQL.Simple (Connection)
  56 import GHC.Generics (Generic)
  57 --import Gargantext.Core.Types.Main (Tree(..))
  58 import Gargantext.Core.Utils.Prefix (unPrefix)
  59 import Gargantext.Database.Types.Node (NodeType(..))
  60 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
  61 import Gargantext.Prelude
  62 import Gargantext.Core.Types (ListType(..), ListId, CorpusId)
  63 import Prelude (Enum, Bounded, minBound, maxBound)
  64 import Servant hiding (Patch)
  65 import Test.QuickCheck (elements)
  66 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  67
  68 ------------------------------------------------------------------------
  69 --data FacetFormat = Table | Chart
  70 data TabType   = Docs     | Terms  | Sources | Authors | Institutes | Trash
  71                | Contacts
  72   deriving (Generic, Enum, Bounded)
  73
  74 instance FromHttpApiData TabType
  75   where
  76     parseUrlPiece "Docs"       = pure Docs
  77     parseUrlPiece "Terms"      = pure Terms
  78     parseUrlPiece "Sources"    = pure Sources
  79     parseUrlPiece "Institutes" = pure Institutes
  80     parseUrlPiece "Authors"    = pure Authors
  81     parseUrlPiece "Trash"      = pure Trash
  82
  83     parseUrlPiece "Contacts"   = pure Contacts
  84
  85     parseUrlPiece _            = Left "Unexpected value of TabType"
  86
  87 instance ToParamSchema   TabType
  88 instance ToJSON    TabType
  89 instance FromJSON  TabType
  90 instance ToSchema  TabType
  91 instance Arbitrary TabType
  92   where
  93     arbitrary = elements [minBound .. maxBound]
  94
  95 ------------------------------------------------------------------------
  96 type NgramsTerm = Text
  97
  98 data NgramsElement =
  99      NgramsElement { _ne_ngrams      :: NgramsTerm
 100                    , _ne_list        :: ListType
 101                    , _ne_occurrences :: Int
 102                    , _ne_parent      :: Maybe NgramsTerm
 103                    , _ne_children    :: Set NgramsTerm
 104                    }
 105       deriving (Ord, Eq, Show, Generic)
 106 $(deriveJSON (unPrefix "_ne_") ''NgramsElement)
 107
 108 instance ToSchema NgramsElement
 109 instance Arbitrary NgramsElement where
 110   arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
 111
 112 ------------------------------------------------------------------------
 113 newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
 114   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 115
 116 instance Arbitrary NgramsTable where
 117   arbitrary = elements
 118               [ NgramsTable
 119                 [ NgramsElement "animal"  GraphList     1  Nothing       (Set.fromList ["dog", "cat"])
 120                 , NgramsElement "cat"     GraphList     1 (Just "animal") mempty
 121                 , NgramsElement "cats"    StopList      4  Nothing        mempty
 122                 , NgramsElement "dog"     GraphList     3 (Just "animal")(Set.fromList ["dogs"])
 123                 , NgramsElement "dogs"    StopList      4 (Just "dog")    mempty
 124                 , NgramsElement "fox"     GraphList     1  Nothing        mempty
 125                 , NgramsElement "object"  CandidateList 2  Nothing        mempty
 126                 , NgramsElement "nothing" StopList      4  Nothing        mempty
 127                 , NgramsElement "organic" GraphList     3  Nothing        (Set.singleton "flower")
 128                 , NgramsElement "flower"  GraphList     3 (Just "organic") mempty
 129                 , NgramsElement "moon"    CandidateList 1  Nothing         mempty
 130                 , NgramsElement "sky"     StopList      1  Nothing         mempty
 131                 ]
 132               ]
 133 instance ToSchema NgramsTable
 134
 135 ------------------------------------------------------------------------
 136 -- On the Client side:
 137 --data Action = InGroup     NgramsId NgramsId
 138 --            | OutGroup    NgramsId NgramsId
 139 --            | SetListType NgramsId ListType
 140
 141 data PatchSet a = PatchSet
 142   { _rem :: Set a
 143   , _add :: Set a
 144   }
 145   deriving (Eq, Ord, Show, Generic)
 146
 147 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 148   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 149
 150 instance ToJSON a => ToJSON (PatchSet a) where
 151   toJSON     = genericToJSON     $ unPrefix "_"
 152   toEncoding = genericToEncoding $ unPrefix "_"
 153
 154 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
 155   parseJSON = genericParseJSON $ unPrefix "_"
 156
 157 instance ToSchema a => ToSchema (PatchSet a)
 158
 159 instance ToSchema a => ToSchema (Replace a) where
 160   declareNamedSchema (_ :: proxy (Replace a)) = do
 161     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 162     return $ NamedSchema (Just "Replace") $ mempty
 163       & type_ .~ SwaggerObject
 164       & properties .~
 165           InsOrdHashMap.fromList
 166           [ ("old", aSchema)
 167           , ("new", aSchema)
 168           ]
 169       & required .~ [ "old", "new" ]
 170
 171 data NgramsPatch =
 172      NgramsPatch { _patch_children :: PatchSet NgramsElement
 173                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
 174                  }
 175       deriving (Ord, Eq, Show, Generic)
 176 $(deriveJSON (unPrefix "_") ''NgramsPatch)
 177
 178 -- instance Semigroup NgramsPatch where
 179
 180 instance ToSchema  NgramsPatch
 181
 182 instance Arbitrary NgramsPatch where
 183   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 184
 185 data NgramsIdPatch =
 186      NgramsIdPatch { _nip_ngrams      :: NgramsTerm
 187                    , _nip_ngramsPatch :: NgramsPatch
 188                    }
 189       deriving (Ord, Eq, Show, Generic)
 190 $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
 191
 192 instance ToSchema  NgramsIdPatch
 193
 194 instance Arbitrary NgramsIdPatch where
 195   arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
 196
 197                        --
 198 -- TODO:
 199 -- * This should be a Map NgramsId NgramsPatch
 200 -- * Patchs -> Patches
 201 newtype NgramsIdPatchs =
 202      NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
 203       deriving (Ord, Eq, Show, Generic, Arbitrary)
 204 $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
 205 instance ToSchema  NgramsIdPatchs
 206
 207 ------------------------------------------------------------------------
 208 ------------------------------------------------------------------------
 209 type Version = Int
 210
 211 data Versioned a = Versioned
 212   { _v_version :: Version
 213   , _v_data    :: a
 214   }
 215
 216 {-
 217 -- TODO sequencs of modifications (Patchs)
 218 type NgramsIdPatch = Patch NgramsId NgramsPatch
 219
 220 ngramsPatch :: Int -> NgramsPatch
 221 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 222
 223 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 224 toEdit n p = Edit n p
 225 ngramsIdPatch :: Patch NgramsId NgramsPatch
 226 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 227                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 228                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 229                                        ]
 230
 231 -- applyPatchBack :: Patch -> IO Patch
 232 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 233 -}
 234 ------------------------------------------------------------------------
 235 ------------------------------------------------------------------------
 236 ------------------------------------------------------------------------
 237
 238 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 239                       :> QueryParam "ngramsType"   TabType
 240                       :> QueryParam "list"   ListId
 241                       :> Get    '[JSON] NgramsTable
 242
 243 type TableNgramsApi = Summary " Table Ngrams API Change"
 244                       :> QueryParam "list"   ListId
 245                       :> ReqBody '[JSON] NgramsIdPatchsFeed -- Versioned ...
 246                       :> Put     '[JSON] NgramsIdPatchsBack -- Versioned ...
 247
 248 type NgramsIdPatchsFeed = NgramsIdPatchs
 249 type NgramsIdPatchsBack = NgramsIdPatchs
 250
 251
 252 {-
 253 toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
 254 -- toLists = undefined
 255 toLists lId np = [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
 256
 257 toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
 258 toList = undefined
 259
 260 toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
 261 toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
 262
 263 toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
 264 -- toGroup = undefined
 265 toGroup lId addOrRem (NgramsIdPatch ngId patch)  =
 266   map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
 267
 268 -}
 269
 270 tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
 271 tableNgramsPatch = undefined
 272 {-
 273 tableNgramsPatch conn corpusId maybeList patchs = do
 274   listId <- case maybeList of
 275               Nothing      -> defaultList conn corpusId
 276               Just listId' -> pure listId'
 277   _ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
 278   _ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
 279   _ <- updateNodeNgrams conn (toLists listId patchs)
 280   pure (NgramsIdPatchs [])
 281 -}
 282
 283 -- | TODO Errors management
 284 --  TODO: polymorphic for Annuaire or Corpus or ...
 285 getTableNgrams :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
 286 getTableNgrams c cId maybeTabType maybeListId = do
 287   let lieu = "Garg.API.Ngrams: " :: Text
 288   let ngramsType = case maybeTabType of
 289         Nothing  -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
 290         Just tab -> case tab of
 291             Sources    -> Ngrams.Sources
 292             Authors    -> Ngrams.Authors
 293             Institutes -> Ngrams.Institutes
 294             Terms      -> Ngrams.NgramsTerms
 295             _          -> panic $ lieu <> "No Ngrams for this tab"
 296
 297   listId <- case maybeListId of
 298       Nothing -> Ngrams.defaultList c cId
 299       Just lId -> pure lId
 300
 301   (ngramsTableDatas, mapToParent, mapToChildren) <-
 302     Ngrams.getNgramsTableDb c NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId)
 303
 304   -- printDebug "ngramsTableDatas" ngramsTableDatas
 305
 306   pure $ NgramsTable $ map (\(Ngrams.NgramsTableData ngs _ lt w) ->
 307                               NgramsElement ngs
 308                                             (maybe (panic $ lieu <> "listType") identity lt)
 309                                             (round w)
 310                                             (lookup ngs mapToParent)
 311                                             (maybe mempty identity $ lookup ngs mapToChildren)
 312                            ) ngramsTableDatas
 313
 314