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