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