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 TemplateHaskell   #-}
  27 {-# LANGUAGE TypeOperators     #-}
  28 {-# LANGUAGE FlexibleInstances #-}
  29 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  30
  31 module Gargantext.API.Ngrams
  32   where
  33
  34 -- import Gargantext.Database.User  (UserId)
  35 import Data.Patch.Class (Replace(..), replace)
  36 import qualified Data.Map.Strict.Patch as PM
  37 import Data.Monoid
  38 import Data.Semigroup
  39 import Data.Set (Set)
  40 import qualified Data.Set as Set
  41 --import Data.Maybe (catMaybes)
  42 --import qualified Data.Map.Strict as DM
  43 --import qualified Data.Set as Set
  44 import Control.Lens (view)
  45 import Data.Aeson (FromJSON, ToJSON)
  46 import Data.Aeson.TH (deriveJSON)
  47 import Data.Either(Either(Left))
  48 import Data.List (concat)
  49 import Data.Set (Set)
  50 import Data.Swagger (ToSchema, ToParamSchema)
  51 import Data.Text (Text)
  52 import Database.PostgreSQL.Simple (Connection)
  53 import GHC.Generics (Generic)
  54 import Gargantext.Core.Types (node_id)
  55 import Gargantext.Core.Types.Main (Tree(..))
  56 import Gargantext.Core.Utils.Prefix (unPrefix)
  57 import Gargantext.Database.Ngrams (NgramsId)
  58 import Gargantext.Database.Node (getListsWithParentId)
  59 -- import Gargantext.Database.NodeNgram -- (NodeNgram(..), NodeNgram, updateNodeNgrams, NodeNgramPoly)
  60 import Gargantext.Database.NodeNgramsNgrams -- (NodeNgramsNgramsPoly(NodeNgramsNgrams))
  61 import Gargantext.Prelude
  62 import Gargantext.Text.List.Types (ListType(..), ListId, ListTypeId) --,listTypeId )
  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 -- import qualified Data.Set as Set
  68
  69 ------------------------------------------------------------------------
  70 --data FacetFormat = Table | Chart
  71 data TabType   = Docs   | Terms  | Sources | Authors | Trash
  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 "Authors" = pure Authors
  80     parseUrlPiece "Trash"   = pure Trash
  81     parseUrlPiece _         = Left "Unexpected value of TabType"
  82
  83 instance ToParamSchema   TabType
  84 instance ToJSON    TabType
  85 instance FromJSON  TabType
  86 instance ToSchema  TabType
  87 instance Arbitrary TabType
  88   where
  89     arbitrary = elements [minBound .. maxBound]
  90
  91 ------------------------------------------------------------------------
  92 type NgramsTerm = Text
  93
  94 data NgramsElement =
  95      NgramsElement { _ne_ngrams      :: NgramsTerm
  96                    , _ne_list        :: ListType
  97                    , _ne_occurrences :: Int
  98                    , _ne_root        :: Maybe NgramsTerm
  99                    , _ne_children    :: Set NgramsTerm
 100                    }
 101       deriving (Ord, Eq, Show, Generic)
 102 $(deriveJSON (unPrefix "_ne_") ''NgramsElement)
 103
 104 instance ToSchema NgramsElement
 105 instance Arbitrary NgramsElement where
 106   arbitrary = elements [NgramsElement "sport" StopList 1 Nothing mempty]
 107
 108 ------------------------------------------------------------------------
 109 newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
 110   deriving (Ord, Eq, Generic, ToJSON, FromJSON)
 111
 112 instance Arbitrary NgramsTable where
 113   arbitrary = elements
 114               [ NgramsTable
 115                 [ NgramsElement "animal" GraphList 1 Nothing (Set.fromList ["dog"])
 116                 ,    NgramsElement "dog" GraphList 3 (Just "animal")
 117                         (Set.fromList ["object", "cat", "nothing"])
 118                 ,    NgramsElement "object" CandidateList 2 (Just "animal") mempty
 119                 ,    NgramsElement "cat"    GraphList 1 (Just "animal") mempty
 120                 ,    NgramsElement "nothing" StopList 4 (Just "animal") mempty
 121                 ]
 122               , NgramsTable
 123                 [ NgramsElement "plant" GraphList 3 Nothing
 124                         (Set.fromList ["flower", "moon", "cat", "sky"])
 125                 ,    NgramsElement "flower" GraphList 3 (Just "plant") mempty
 126                 ,    NgramsElement "moon" CandidateList 1 (Just "plant") mempty
 127                 ,    NgramsElement "cat"  GraphList 2 (Just "plant") mempty
 128                 ,    NgramsElement "sky" StopList 1 (Just "plant") mempty
 129                 ]
 130               ]
 131 instance ToSchema NgramsTable
 132
 133 ------------------------------------------------------------------------
 134 -- On the Client side:
 135 --data Action = InGroup     NgramsId NgramsId
 136 --            | OutGroup    NgramsId NgramsId
 137 --            | SetListType NgramsId ListType
 138
 139 data PatchSet a = PatchSet
 140   { _rem :: Set a
 141   , _add :: Set a
 142   }
 143   deriving (Eq, Ord, Show, Generic)
 144
 145 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 146   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 147
 148 instance ToSchema a => ToSchema (PatchSet a)
 149
 150 instance ToSchema a => ToSchema (Replace a)
 151
 152 data NgramsPatch =
 153      NgramsPatch { _patch_children :: PatchSet NgramsElement
 154                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
 155                  }
 156       deriving (Ord, Eq, Show, Generic)
 157 $(deriveJSON (unPrefix "_") ''NgramsPatch)
 158
 159 instance Semigroup NgramsPatch where
 160
 161 instance ToSchema  NgramsPatch
 162
 163 instance Arbitrary NgramsPatch where
 164   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 165
 166 data NgramsIdPatch =
 167      NgramsIdPatch { _nip_ngramsId    :: NgramsTerm
 168                    , _nip_ngramsPatch :: NgramsPatch
 169                    }
 170       deriving (Ord, Eq, Show, Generic)
 171
 172 $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
 173
 174 instance ToSchema  NgramsIdPatch
 175
 176 instance Arbitrary NgramsIdPatch where
 177   arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
 178
 179                        --
 180 -- TODO:
 181 -- * This should be a Map NgramsId NgramsPatch
 182 -- * Patchs -> Patches
 183 newtype NgramsIdPatchs =
 184      NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
 185       deriving (Ord, Eq, Show, Generic, Arbitrary)
 186 $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
 187 instance ToSchema  NgramsIdPatchs
 188
 189 ------------------------------------------------------------------------
 190 ------------------------------------------------------------------------
 191 type Version = Int
 192
 193 data Versioned a = Versioned
 194   { _v_version :: Version
 195   , _v_data    :: a
 196   }
 197
 198
 199 {-
 200 -- TODO sequencs of modifications (Patchs)
 201 type NgramsIdPatch = Patch NgramsId NgramsPatch
 202
 203 ngramsPatch :: Int -> NgramsPatch
 204 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 205
 206 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 207 toEdit n p = Edit n p
 208 ngramsIdPatch :: Patch NgramsId NgramsPatch
 209 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 210                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 211                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 212                                        ]
 213
 214 -- applyPatchBack :: Patch -> IO Patch
 215 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 216 -}
 217 ------------------------------------------------------------------------
 218 ------------------------------------------------------------------------
 219 ------------------------------------------------------------------------
 220 type CorpusId = Int
 221 type TableNgramsApi = Summary " Table Ngrams API Change"
 222                       :> QueryParam "list"   ListId
 223                       :> ReqBody '[JSON] NgramsIdPatchs -- Versioned ...
 224                       :> Put     '[JSON] NgramsIdPatchsBack -- Versioned ...
 225
 226 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 227                       :> QueryParam "ngramsType"   TabType
 228                       :> QueryParam "list"   ListId
 229                       :> Get    '[JSON] NgramsTable
 230
 231 type NgramsIdPatchsFeed = NgramsIdPatchs
 232 type NgramsIdPatchsBack = NgramsIdPatchs
 233
 234
 235 defaultList :: Connection -> CorpusId -> IO ListId
 236 defaultList c cId = view node_id <$> maybe (panic noListFound) identity
 237   <$> head
 238   <$> getListsWithParentId c cId
 239   where
 240     noListFound = "Gargantext.API.Ngrams.defaultList: no list found"
 241
 242 {-
 243 toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
 244 toLists lId np =
 245   [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
 246
 247 toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
 248 toList = undefined
 249
 250 toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
 251 toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
 252
 253 toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
 254 toGroup = undefined
 255 -}
 256 {-
 257 toGroup lId addOrRem (NgramsIdPatch ngId patch)  =
 258   map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
 259 -}
 260
 261
 262 tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
 263 tableNgramsPatch = undefined
 264 {-
 265 tableNgramsPatch conn corpusId maybeList patchs = do
 266   listId <- case maybeList of
 267               Nothing      -> defaultList conn corpusId
 268               Just listId' -> pure listId'
 269   _ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
 270   _ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
 271   _ <- updateNodeNgrams conn (toLists listId patchs)
 272   pure (NgramsIdPatchs [])
 273   -}
 274
 275 getTableNgramsPatch :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
 276 getTableNgramsPatch = undefined