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 | Institutes | 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 "Institutes" = pure Institutes
  81     parseUrlPiece "Authors"    = pure Authors
  82     parseUrlPiece "Trash"      = pure Trash
  83     parseUrlPiece _            = Left "Unexpected value of TabType"
  84
  85 instance ToParamSchema   TabType
  86 instance ToJSON    TabType
  87 instance FromJSON  TabType
  88 instance ToSchema  TabType
  89 instance Arbitrary TabType
  90   where
  91     arbitrary = elements [minBound .. maxBound]
  92
  93 ------------------------------------------------------------------------
  94 type NgramsTerm = Text
  95
  96 data NgramsElement =
  97      NgramsElement { _ne_ngrams      :: NgramsTerm
  98                    , _ne_list        :: ListType
  99                    , _ne_occurrences :: Int
 100                    , _ne_parent      :: Maybe NgramsTerm
 101                    , _ne_children    :: Set NgramsTerm
 102                    }
 103       deriving (Ord, Eq, Show, Generic)
 104 $(deriveJSON (unPrefix "_ne_") ''NgramsElement)
 105
 106 instance ToSchema NgramsElement
 107 instance Arbitrary NgramsElement where
 108   arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
 109
 110 ------------------------------------------------------------------------
 111 newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
 112   deriving (Ord, Eq, Generic, ToJSON, FromJSON)
 113
 114 instance Arbitrary NgramsTable where
 115   arbitrary = elements
 116               [ NgramsTable
 117                 [ NgramsElement "animal"  GraphList     1  Nothing       (Set.fromList ["dog", "cat"])
 118                 , NgramsElement "cat"     GraphList     1 (Just "animal") mempty
 119                 , NgramsElement "dog"     GraphList     3 (Just "animal")(Set.fromList ["dogs"])
 120                 , NgramsElement "dogs"    StopList      4 (Just "dog")    mempty
 121                 , NgramsElement "object"  CandidateList 2  Nothing        mempty
 122                 , NgramsElement "nothing" StopList      4  Nothing        mempty
 123                 ]
 124               , NgramsTable
 125                 [ NgramsElement "organic" GraphList     3  Nothing        (Set.singleton "flower")
 126                 , NgramsElement "flower"  GraphList     3 (Just "organic") mempty
 127                 , NgramsElement "moon"    CandidateList 1  Nothing         mempty
 128                 , NgramsElement "cat"     GraphList     2  Nothing         mempty
 129                 , NgramsElement "sky"     StopList      1  Nothing         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_ngrams      :: NgramsTerm
 186                    , _nip_ngramsPatch :: NgramsPatch
 187                    }
 188       deriving (Ord, Eq, Show, Generic)
 189 $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
 190
 191 instance ToSchema  NgramsIdPatch
 192
 193 instance Arbitrary NgramsIdPatch where
 194   arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
 195
 196                        --
 197 -- TODO:
 198 -- * This should be a Map NgramsId NgramsPatch
 199 -- * Patchs -> Patches
 200 newtype NgramsIdPatchs =
 201      NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
 202       deriving (Ord, Eq, Show, Generic, Arbitrary)
 203 $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
 204 instance ToSchema  NgramsIdPatchs
 205
 206 ------------------------------------------------------------------------
 207 ------------------------------------------------------------------------
 208 type Version = Int
 209
 210 data Versioned a = Versioned
 211   { _v_version :: Version
 212   , _v_data    :: a
 213   }
 214
 215 {-
 216 -- TODO sequencs of modifications (Patchs)
 217 type NgramsIdPatch = Patch NgramsId NgramsPatch
 218
 219 ngramsPatch :: Int -> NgramsPatch
 220 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 221
 222 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 223 toEdit n p = Edit n p
 224 ngramsIdPatch :: Patch NgramsId NgramsPatch
 225 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 226                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 227                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 228                                        ]
 229
 230 -- applyPatchBack :: Patch -> IO Patch
 231 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 232 -}
 233 ------------------------------------------------------------------------
 234 ------------------------------------------------------------------------
 235 ------------------------------------------------------------------------
 236 type CorpusId = Int
 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 defaultList :: Connection -> CorpusId -> IO ListId
 253 defaultList c cId = view node_id <$> maybe (panic noListFound) identity
 254   <$> head
 255   <$> getListsWithParentId c cId
 256   where
 257     noListFound = "Gargantext.API.Ngrams.defaultList: no list found"
 258
 259 {-
 260 toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
 261 -- toLists = undefined
 262 toLists lId np = [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
 263
 264 toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
 265 toList = undefined
 266
 267 toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
 268 toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
 269
 270 toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
 271 -- toGroup = undefined
 272 toGroup lId addOrRem (NgramsIdPatch ngId patch)  =
 273   map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
 274
 275 -}
 276
 277 tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
 278 tableNgramsPatch = undefined
 279 {-
 280 tableNgramsPatch conn corpusId maybeList patchs = do
 281   listId <- case maybeList of
 282               Nothing      -> defaultList conn corpusId
 283               Just listId' -> pure listId'
 284   _ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
 285   _ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
 286   _ <- updateNodeNgrams conn (toLists listId patchs)
 287   pure (NgramsIdPatchs [])
 288 -}
 289
 290 getTableNgramsPatch :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
 291 getTableNgramsPatch = undefined