[WIP] [Forgot password] render in FE
[gargantext.git] / src / Gargantext / Database / Schema / Ngrams.hs
index a1dd4b6efba27397908282717df0621bd82b9fc0..ff3f00213d8f9a21c20785d88137d46266b1fef4 100644 (file)
@@ -1,5 +1,5 @@
 {-|
-Module      : Gargantext.Database.Schema.Ngrams
+Module      : Gargantext.Database.Schema.NgramsPostag
 Description : Ngram connection to the Database
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3
@@ -11,50 +11,55 @@ Ngrams connection to the Database.
 
 -}
 
-{-# LANGUAGE Arrows                     #-}
-{-# LANGUAGE FunctionalDependencies     #-}
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE QuasiQuotes            #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
 module Gargantext.Database.Schema.Ngrams
   where
 
+import Data.Maybe (fromMaybe)
+import Data.HashMap.Strict (HashMap)
+import Data.Hashable (Hashable)
 import Codec.Serialise (Serialise())
 import Control.Lens (over)
 import Control.Monad (mzero)
 import Data.Aeson
 import Data.Aeson.Types (toJSONKeyText)
-import Data.Map (Map, fromList, lookup)
-import Data.Text (Text, splitOn, pack)
-import Gargantext.Core.Types (TODO(..))
+import Data.Map (fromList, lookup)
+import Data.Text (Text, splitOn, pack, strip)
+import Gargantext.Core.Types (TODO(..), Typed(..))
 import Gargantext.Prelude
-import Prelude (Functor)
-import Servant (FromHttpApiData, parseUrlPiece, Proxy(..))
+import Servant (FromHttpApiData(..), Proxy(..), ToHttpApiData(..))
 import Text.Read (read)
+import Gargantext.Core (HasDBid(..))
+import Gargantext.Database.Types
 import Gargantext.Database.Schema.Prelude
 import qualified Database.PostgreSQL.Simple as PGS
+import qualified Data.HashMap.Strict as HashMap
 
 
-type NgramsId    = Int
-type NgramsTerms = Text
-type Size        = Int
+type NgramsId  = Int
+type Size      = Int
 
 data NgramsPoly id terms n = NgramsDB { _ngrams_id    :: !id
                                       , _ngrams_terms :: !terms
                                       , _ngrams_n     :: !n
                                       } deriving (Show)
 
-type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
-                                   (Column PGText)
-                                   (Column PGInt4)
+type NgramsWrite = NgramsPoly (Maybe (Column SqlInt4))
+                                   (Column SqlText)
+                                   (Column SqlInt4)
 
-type NgramsRead  = NgramsPoly (Column PGInt4)
-                              (Column PGText)
-                              (Column PGInt4)
+type NgramsRead  = NgramsPoly (Column SqlInt4)
+                              (Column SqlText)
+                              (Column SqlInt4)
 
-type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
-                                 (Column (Nullable PGText))
-                                 (Column (Nullable PGInt4))
+type NgramsReadNull = NgramsPoly (Column (Nullable SqlInt4))
+                                 (Column (Nullable SqlText))
+                                 (Column (Nullable SqlInt4))
 
 type NgramsDB = NgramsPoly Int Text Int
 
@@ -63,25 +68,24 @@ makeLenses ''NgramsPoly
 
 
 ngramsTable :: Table NgramsWrite NgramsRead
-ngramsTable = Table "ngrams" (pNgramsDb NgramsDB { _ngrams_id    = optional "id"
-                                                 , _ngrams_terms = required "terms"
-                                                 , _ngrams_n     = required "n"
+ngramsTable = Table "ngrams" (pNgramsDb NgramsDB { _ngrams_id    = optionalTableField "id"
+                                                 , _ngrams_terms = requiredTableField "terms"
+                                                 , _ngrams_n     = requiredTableField "n"
                                                  }
                               )
 
-
-
 -- | Main Ngrams Types
 -- | Typed Ngrams
 -- Typed Ngrams localize the context of the ngrams
--- ngrams in source field of document has Sources Type
--- ngrams in authors field of document has Authors Type
--- ngrams in text (title or abstract) of documents has Terms Type
+-- ngrams in source  field  of document  has Sources Type
+-- ngrams in authors field  of document  has Authors Type
+-- ngrams in text    fields of documents has Terms   Type (i.e. either title or abstract)
 data NgramsType = Authors | Institutes | Sources | NgramsTerms
   deriving (Eq, Show, Read, Ord, Enum, Bounded, Generic)
 
 instance Serialise NgramsType
 
+
 ngramsTypes :: [NgramsType]
 ngramsTypes = [minBound..]
 
@@ -105,26 +109,29 @@ instance FromField NgramsTypeId where
 instance FromJSON NgramsType
 instance FromJSONKey NgramsType where
    fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
+
 instance ToJSON NgramsType
 instance ToJSONKey NgramsType where
    toJSONKey = toJSONKeyText (pack . show)
 
 instance FromHttpApiData NgramsType where
   parseUrlPiece n = pure $ (read . cs) n
+instance ToHttpApiData NgramsType where
+  toUrlPiece = pack . show
 
 instance ToParamSchema NgramsType where
   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 
 
-instance QueryRunnerColumnDefault (Nullable PGInt4) NgramsTypeId
+instance DefaultFromField (Nullable SqlInt4) NgramsTypeId
   where
-    queryRunnerColumnDefault = fieldQueryRunnerColumn
+    defaultFromField = fromPGSFromField
 
-pgNgramsType :: NgramsType -> Column PGInt4
+pgNgramsType :: NgramsType -> Column SqlInt4
 pgNgramsType = pgNgramsTypeId . ngramsTypeId
 
-pgNgramsTypeId :: NgramsTypeId -> Column PGInt4
-pgNgramsTypeId (NgramsTypeId n) = pgInt4 n
+pgNgramsTypeId :: NgramsTypeId -> Column SqlInt4
+pgNgramsTypeId (NgramsTypeId n) = sqlInt4 n
 
 ngramsTypeId :: NgramsType -> NgramsTypeId
 ngramsTypeId Authors     = 1
@@ -138,19 +145,45 @@ fromNgramsTypeId id = lookup id
                                | nt <- [minBound .. maxBound] :: [NgramsType]
                                ]
 
+unNgramsTypeId :: NgramsTypeId -> Int
+unNgramsTypeId (NgramsTypeId i) = i
+
+toNgramsTypeId :: Int -> NgramsTypeId
+toNgramsTypeId i = NgramsTypeId i
+
+instance HasDBid NgramsType where
+  toDBid   = unNgramsTypeId . ngramsTypeId
+  fromDBid = fromMaybe (panic "NgramsType id not indexed") . fromNgramsTypeId . toNgramsTypeId
+
+------------------------------------------------------------------------
 ------------------------------------------------------------------------
 -- | TODO put it in Gargantext.Core.Text.Ngrams
-data Ngrams = Ngrams { _ngramsTerms :: Text
-                     , _ngramsSize  :: Int
-           } deriving (Generic, Show, Eq, Ord)
+data Ngrams = UnsafeNgrams { _ngramsTerms :: Text
+                           , _ngramsSize  :: Int
+                           }
+  deriving (Generic, Show, Eq, Ord)
+
+instance Hashable Ngrams
 
 makeLenses ''Ngrams
 instance PGS.ToRow Ngrams where
-  toRow (Ngrams t s) = [toField t, toField s]
+  toRow (UnsafeNgrams t s) = [toField t, toField s]
+
+instance FromField Ngrams where
+  fromField fld mdata = do
+    x <- fromField fld mdata
+    pure $ text2ngrams x
+
+instance PGS.ToRow Text where
+  toRow t = [toField t]
 
 text2ngrams :: Text -> Ngrams
-text2ngrams txt = Ngrams txt $ length $ splitOn " " txt
+text2ngrams txt = UnsafeNgrams txt' $ length $ splitOn " " txt'
+  where
+    txt' = strip txt
 
+
+------------------------------------------------------------------------
 -------------------------------------------------------------------------
 -- | TODO put it in Gargantext.Core.Text.Ngrams
 -- Named entity are typed ngrams of Terms Ngrams
@@ -163,41 +196,23 @@ makeLenses ''NgramsT
 
 instance Functor NgramsT where
   fmap = over ngramsT
------------------------------------------------------------------------
-data NgramsIndexed =
-  NgramsIndexed
-  { _ngrams   :: Ngrams
-  , _ngramsId :: NgramsId
-  } deriving (Show, Generic, Eq, Ord)
 
-makeLenses ''NgramsIndexed
-------------------------------------------------------------------------
-data NgramIds =
-  NgramIds
-  { ngramId    :: Int
-  , ngramTerms :: Text
-  } deriving (Show, Generic, Eq, Ord)
-
-instance PGS.FromRow NgramIds where
-  fromRow = NgramIds <$> field <*> field
-
-----------------------
-withMap :: Map NgramsTerms NgramsId -> NgramsTerms -> NgramsId
-withMap m n = maybe (panic "withMap: should not happen") identity (lookup n m)
+-----------------------------------------------------------------------
+withMap :: HashMap Text NgramsId -> Text -> NgramsId
+withMap m n = maybe (panic $ "[G.D.S.Ngrams.withMap] Should not happen" <> (cs $ show n))
+                    identity (HashMap.lookup n m)
 
-indexNgramsT :: Map NgramsTerms NgramsId -> NgramsT Ngrams -> NgramsT NgramsIndexed
+indexNgramsT :: HashMap Text NgramsId -> NgramsT Ngrams -> NgramsT (Indexed Int Ngrams)
 indexNgramsT = fmap . indexNgramsWith . withMap
 
-indexNgrams :: Map NgramsTerms NgramsId -> Ngrams -> NgramsIndexed
-indexNgrams = indexNgramsWith . withMap
-
--- NP: not sure we need it anymore
-indexNgramsTWith :: (NgramsTerms -> NgramsId) -> NgramsT Ngrams -> NgramsT NgramsIndexed
-indexNgramsTWith = fmap . indexNgramsWith
-
-indexNgramsWith :: (NgramsTerms -> NgramsId) -> Ngrams -> NgramsIndexed
-indexNgramsWith f n = NgramsIndexed n (f $ _ngramsTerms n)
-
-
+-- | TODO replace NgramsT whith Typed NgramsType Ngrams
+indexTypedNgrams :: HashMap Text NgramsId
+                 -> Typed NgramsType Ngrams
+                 -> Typed NgramsType (Indexed Int Ngrams)
+indexTypedNgrams = fmap . indexNgramsWith . withMap
 
+indexNgrams :: HashMap Text NgramsId -> Ngrams -> Indexed Int Ngrams
+indexNgrams = indexNgramsWith . withMap
 
+indexNgramsWith :: (Text -> NgramsId) -> Ngrams -> Indexed Int Ngrams
+indexNgramsWith f n = Indexed (f $ _ngramsTerms n) n