[ngrams] NgramsTerm as a newtype

This is to disallow for NgramsTerm keys with spaces.

Can be modified for other kinds of term normalization later.

src/Gargantext/API/Ngrams.hs

@@ -40,6 +40,8 @@ module Gargantext.API.Ngrams
   , NgramsTablePatch
   , NgramsTableMap
 
+  , NgramsTerm(..)
+
   , NgramsElement(..)
   , mkNgramsElement
   , mergeNgramsElement
@@ -114,11 +116,12 @@ import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), C
 import Data.Set (Set)
 import qualified Data.Set as S
 import qualified Data.Set as Set
+import Data.String (IsString, fromString)
 import Data.Swagger hiding (version, patch)
-import Data.Text (Text, count, isInfixOf, unpack)
+import Data.Text (Text, count, isInfixOf, pack, strip, unpack)
 import Data.Text.Lazy.IO as DTL
 import Data.Validity
-import Database.PostgreSQL.Simple.FromField (FromField, fromField)
+import Database.PostgreSQL.Simple.FromField (FromField, fromField, ResultError(ConversionFailed), returnError)
 import Formatting (hprint, int, (%))
 import Formatting.Clock (timeSpecs)
 import GHC.Generics (Generic)
@@ -208,7 +211,25 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
   declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
 
 ------------------------------------------------------------------------
-type NgramsTerm = Text
+newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text }
+  deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema)
+
+instance FromJSONKey NgramsTerm where
+  fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t
+
+instance IsString NgramsTerm where
+  fromString s = NgramsTerm $ pack s
+
+instance FromField NgramsTerm
+  where
+    fromField field mb = do
+      v <- fromField field mb
+      case fromJSON v of
+        Success a -> pure $ NgramsTerm $ strip a
+        Error _err -> returnError ConversionFailed field
+                      $ List.intercalate " " [ "cannot parse hyperdata for JSON: "
+                                             , show v
+                                             ]
 
 data RootParent = RootParent
   { _rp_root   :: NgramsTerm
@@ -265,7 +286,7 @@ mkNgramsElement ngrams list rp children =
   NgramsElement ngrams size list 1 (_rp_root <$> rp) (_rp_parent <$> rp) children
   where
     -- TODO review
-    size = 1 + count " " ngrams
+    size = 1 + (count " " $ unNgramsTerm ngrams)
 
 newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
 newNgramsElement mayList ngrams =
@@ -937,7 +958,8 @@ setListNgrams listId ngramsType ns = do
 putListNgrams :: (HasInvalidError err, RepoCmdM env err m)
               => NodeId
               -> TableNgrams.NgramsType
-              -> [NgramsElement] -> m ()
+              -> [NgramsElement]
+              -> m ()
 putListNgrams _ _ [] = pure ()
 putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
   where
@@ -949,9 +971,9 @@ putListNgrams' :: (HasInvalidError err, RepoCmdM env err m)
                -> Map NgramsTerm NgramsRepoElement
                -> m ()
 putListNgrams' nodeId ngramsType ns = do
-  -- printDebug "[putLictNgrams'] nodeId" nodeId
-  -- printDebug "[putLictNgrams'] ngramsType" ngramsType
-  -- printDebug "[putListNgrams'] ns" ns
+  printDebug "[putListNgrams'] nodeId" nodeId
+  printDebug "[putListNgrams'] ngramsType" ngramsType
+  printDebug "[putListNgrams'] ns" ns
 
   let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
       (p0, p0_validity) = PM.singleton nodeId p1
@@ -1040,7 +1062,8 @@ tableNgramsPull listId ngramsType p_version = do
 -- client.
 -- TODO-ACCESS check
 tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
-                 => TabType -> ListId
+                 => TabType
+                 -> ListId
                  -> Versioned NgramsTablePatch
                  -> m (Versioned NgramsTablePatch)
 tableNgramsPut tabType listId (Versioned p_version p_table)
@@ -1157,7 +1180,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
     setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
     setScores False table = pure table
     setScores True  table = do
-      let ngrams_terms = (table ^.. each . ne_ngrams)
+      let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams)
       t1 <- getTime'
       occurrences <- getOccByNgramsOnlyFast' nId
                                              listId
@@ -1174,7 +1197,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
                                             ngrams_terms
       -}
       let
-        setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
+        setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences
 
       pure $ table & each %~ setOcc
     ---------------------------------------
@@ -1216,13 +1239,13 @@ scoresRecomputeTableNgrams nId tabType listId = do
 
     setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
     setScores table = do
-      let ngrams_terms = (table ^.. each . ne_ngrams)
+      let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams)
       occurrences <- getOccByNgramsOnlyFast' nId
                                              listId
                                             ngramsType
                                             ngrams_terms
       let
-        setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
+        setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences
 
       pure $ table & each %~ setOcc
 
@@ -1305,7 +1328,7 @@ getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool
 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
   getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
     where
-      searchQuery = maybe (const True) isInfixOf mt
+      searchQuery (NgramsTerm nt) = maybe (const True) isInfixOf mt nt
 
 getTableNgramsVersion :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
                => NodeId
@@ -1332,7 +1355,7 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
   ns <- selectNodesWithUsername NodeList userMaster
   let ngramsType = ngramsTypeFromTabType tabType
   ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
-  let searchQuery = flip S.member (S.fromList ngs)
+  let searchQuery (NgramsTerm nt) = flip S.member (S.fromList ngs) nt
   getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 
 

src/Gargantext/API/Ngrams/NTree.hs

@@ -14,13 +14,8 @@ Portability : POSIX
 module Gargantext.API.Ngrams.NTree
   where
 
-import Data.Text (Text)
-import Gargantext.Prelude
-import GHC.Generics (Generic)
 import Data.Aeson.TH (deriveJSON)
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
-import Gargantext.Core.Types (ListType(..), NodeId)
-import Gargantext.API.Ngrams
+import Data.Text (Text)
 import Data.Tree
 import Data.Maybe (catMaybes)
 import Data.Map (Map)
@@ -29,8 +24,15 @@ import Data.Swagger
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.List as List
+import GHC.Generics (Generic)
 import Test.QuickCheck
 
+import Gargantext.Prelude
+
+import Gargantext.API.Ngrams
+import Gargantext.Core.Types (ListType(..), NodeId)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+
 type Children = Text
 type Root = Text
 
@@ -53,19 +55,21 @@ instance Arbitrary MyTree
 toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [MyTree]
 toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
   where
-    buildNode r = maybe ((r, value r),[]) (\x -> ((r, value r), mSetToList $ _nre_children x)) (Map.lookup r m)
+    buildNode r = maybe ((r, value r),[])
+                        (\x -> ((r, value r), unNgramsTerm <$> (mSetToList $ _nre_children x)))
+                        (Map.lookup r m)
 
     value l = maybe 0 (fromIntegral . Set.size) $ Map.lookup l vs
 
+    rootsCandidates :: [NgramsTerm]
     rootsCandidates = catMaybes
                     $ List.nub
-                    $ map (\(c,c') -> case _nre_root c' of
-                                       Nothing -> Just c
-                                       _ -> _nre_root c' ) (Map.toList m)
+                    $ map (\(c, c') -> case _nre_root c' of
+                                       Nothing -> Just $ NgramsTerm c
+                                       _ -> _nre_root c') (Map.toList m)
 
     roots = map fst
           $ filter (\(_,l) -> l == lt)
           $ catMaybes
-          $ map (\c -> (,) <$> Just c <*> (_nre_list <$> Map.lookup c m)) rootsCandidates
-
-
+          $ map (\c -> (,) <$> Just c <*> (_nre_list <$> Map.lookup c m))
+          $ (unNgramsTerm <$> rootsCandidates)

src/Gargantext/API/Ngrams/Tools.hs

@@ -17,15 +17,16 @@ import Control.Concurrent
 import Control.Lens (_Just, (^.), at, view)
 import Control.Monad.Reader
 import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
 import Data.Set (Set)
 import Data.Text (Text)
 import Data.Validity
+
 import Gargantext.API.Ngrams
 import Gargantext.Core.Types (ListType(..), NodeId, ListId)
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
 
 type RootTerm = Text
 
@@ -36,7 +37,7 @@ getRepo = do
 
 listNgramsFromRepo :: [ListId] -> NgramsType
                    -> NgramsRepo -> Map Text NgramsRepoElement
-listNgramsFromRepo nodeIds ngramsType repo = ngrams
+listNgramsFromRepo nodeIds ngramsType repo = Map.mapKeys unNgramsTerm ngrams
   where
     ngramsMap = repo ^. r_state . at ngramsType . _Just
 
@@ -72,7 +73,7 @@ mapTermListRoot :: [ListId]
                 -> NgramsRepo
                 -> Map Text (ListType, (Maybe Text))
 mapTermListRoot nodeIds ngramsType repo =
-  Map.fromList [ (t, (_nre_list nre, _nre_root nre))
+  Map.fromList [ (t, (_nre_list nre, unNgramsTerm <$> _nre_root nre))
                | (t, nre) <- Map.toList ngrams
                ]
   where ngrams = listNgramsFromRepo nodeIds ngramsType repo

src/Gargantext/Core/Text/List.hs

@@ -17,7 +17,15 @@ module Gargantext.Core.Text.List
 import Data.Map (Map)
 import Data.Set (Set)
 import Data.Text (Text)
-import Gargantext.API.Ngrams (NgramsElement, mkNgramsElement, RootParent(..), mSetFromList)
+import qualified Data.Char as Char
+import qualified Data.List as List
+import qualified Data.Map  as Map
+import qualified Data.Set  as Set
+import qualified Data.Text as Text
+
+import Gargantext.Prelude
+
+import Gargantext.API.Ngrams (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList)
 -- import Gargantext.API.Ngrams.Tools (getCoocByNgrams', Diagonal(..))
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Types (ListType(..), MasterCorpusId, UserCorpusId, Ordering(..))
@@ -26,14 +34,8 @@ import Gargantext.Database.Action.Metrics.TFICF (getTficf)
 import Gargantext.Core.Text.Metrics.TFICF (sortTficf)
 import Gargantext.Database.Prelude (Cmd)
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
-import Gargantext.Prelude
 import Gargantext.Core.Text.List.Learn (Model(..))
 -- import Gargantext.Core.Text.Metrics (takeScored)
-import qualified Data.Char as Char
-import qualified Data.List as List
-import qualified Data.Map  as Map
-import qualified Data.Set  as Set
-import qualified Data.Text as Text
 
 
 data NgramsListBuilder = BuilderStepO { stemSize :: Int
@@ -86,8 +88,8 @@ buildNgramsOthersList uCid groupIt nt = do
                              ]
     where
       toElements nType x =
-        Map.fromList [(nt, [ mkNgramsElement t nType Nothing (mSetFromList [])
-                           | (t,_ns) <- x
+        Map.fromList [(nt, [ mkNgramsElement (NgramsTerm t) nType Nothing (mSetFromList [])
+                           | (t, _ns) <- x
                            ]
                      )]
 
@@ -146,14 +148,14 @@ toNgramsElement (GroupedText listType label _ setNgrams) =
     where
       parent = label
       children = Set.toList setNgrams
-      parentElem    = mkNgramsElement parent
+      parentElem    = mkNgramsElement (NgramsTerm parent)
                                       listType
                                       Nothing
-                                      (mSetFromList children)
+                                      (mSetFromList (NgramsTerm <$> children))
       childrenElems = map (\t -> mkNgramsElement t listType
-                                                 (Just $ RootParent parent parent)
+                                                 (Just $ RootParent (NgramsTerm parent) (NgramsTerm parent))
                                                  (mSetFromList [])
-                          ) children
+                          ) (NgramsTerm <$> children)
 
 
 toGargList :: (b -> Bool) -> ListType -> b -> (ListType, b)

src/Gargantext/Database/Action/Flow/List.hs

@@ -26,7 +26,7 @@ import Data.Map (Map, toList)
 import Data.Maybe (Maybe(..), catMaybes)
 import Data.Text (Text)
 
-import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams)
+import Gargantext.API.Ngrams (NgramsElement(..), NgramsTerm(..), putListNgrams)
 import Gargantext.Core.Flow.Types
 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
 import Gargantext.Database.Admin.Types.Node
@@ -97,10 +97,10 @@ flowList_DbRepo :: FlowCmdM env err m
 flowList_DbRepo lId ngs = do
   -- printDebug "listId flowList" lId
   mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
-  let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> parent)
+  let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> (unNgramsTerm <$> parent))
                                  <*>  getCgramsId mapCgramsId ntype ngram
                            | (ntype, ngs') <- Map.toList ngs
-                           , NgramsElement ngram _ _ _ _ parent _ <- ngs'
+                           , NgramsElement (NgramsTerm ngram) _ _ _ _ parent _ <- ngs'
                            ]
   -- Inserting groups of ngrams
   _r <- insert_Node_NodeNgrams_NodeNgrams
@@ -123,7 +123,7 @@ toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
                   -> [NodeNgramsW]
     toNodeNgramsW'' l' (ngrams_type, elms) =
       [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
-       (NgramsElement ngrams_terms' _size list_type _occ _root _parent _children) <- elms
+       (NgramsElement (NgramsTerm ngrams_terms') _size list_type _occ _root _parent _children) <- elms
       ]
 
 

src/Gargantext/Database/Prelude.hs

@@ -33,8 +33,6 @@ import Data.Word (Word16)
 import Database.PostgreSQL.Simple (Connection, connect)
 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
 import Database.PostgreSQL.Simple.Internal  (Field)
-import Gargantext.Prelude
-import Gargantext.Prelude.Config (GargConfig())
 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
 import Opaleye.Aggregate (countRows)
 import System.IO (FilePath)
@@ -44,6 +42,9 @@ import qualified Data.ByteString      as DB
 import qualified Data.List as DL
 import qualified Database.PostgreSQL.Simple as PGS
 
+import Gargantext.Prelude
+import Gargantext.Prelude.Config (GargConfig())
+
 -------------------------------------------------------
 class HasConnectionPool env where
   connPool :: Getter env (Pool Connection)