[FACTO] Clean unused code thanks to Type Classes.

src/Gargantext/Database/Flow.hs

@@ -33,7 +33,7 @@ module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
 --import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
 --import Gargantext.Text.Metrics.TFICF (Tficf(..))
 --import Debug.Trace (trace)
-import Control.Lens ((^.))
+import Control.Lens ((^.), view, Lens')
 import Control.Monad (mapM_)
 import Control.Monad.IO.Class (liftIO)
 import Data.List (concat)
@@ -80,7 +80,6 @@ type FlowCmdM env err m =
   )
 
 
-
 ------------------------------------------------------------------------
 
 flowCorpusDebat :: FlowCmdM env ServantErr m
@@ -116,7 +115,8 @@ flowCorpusSearchInDatabase u la q = do
 
 ------------------------------------------------------------------------
 
-
+-- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
+-- TODO-EVENTS: InsertedNodes
 flowCorpus :: (FlowCmdM env ServantErr m, ToHyperdataDocument a)
            => Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
 flowCorpus u cn la docs = do
@@ -149,7 +149,12 @@ flowCorpusUser l userName corpusName ids = do
   pure userCorpusId
 
 
-insertMasterDocs :: (FlowCmdM env ServantErr m, InsertDb a, AddUniqId a, ToCorpus a, ExtractNgramsT a)
+insertMasterDocs :: ( FlowCmdM env ServantErr m
+                    , AddUniqId a -- Maybe use a Setter her
+                    , UniqId a    -- That is a lens
+                    , InsertDb a
+                    , ExtractNgramsT a
+                    )
                 => TermType Lang -> [a] -> m [DocId]
 insertMasterDocs lang hs  =  do
   (masterUserId, _, masterCorpusId) <- getOrMkRootWithCorpus userMaster corpusMasterName
@@ -158,7 +163,7 @@ insertMasterDocs lang hs  =  do
   let hs' = map addUniqId hs
   ids <- insertDb masterUserId masterCorpusId hs'
 
-  let documentsWithId = mergeData (toInserted ids) (DM.fromList $ map toCorpus hs')
+  let documentsWithId = mergeData (toInserted ids) (DM.fromList $ map viewUniqId' hs')
   docsWithNgrams     <- documentIdWithNgrams (extractNgramsT lang) documentsWithId
 
   let maps            = mapNodeIdNgrams docsWithNgrams
@@ -210,14 +215,18 @@ getOrMkRootWithCorpus username cName = do
 
 ------------------------------------------------------------------------
 
-class ToCorpus a
+class UniqId a
   where
-    toCorpus :: a -> (HashId,a)
+    uniqId :: Lens' a (Maybe HashId)
 
 
-instance ToCorpus HyperdataDocument
+instance UniqId HyperdataDocument
   where
-    toCorpus d = maybe err (\h -> (h,d)) (_hyperdataDocument_uniqId d)
+    uniqId = hyperdataDocument_uniqId
+
+
+viewUniqId' :: UniqId a => a -> (HashId, a)
+viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
       where
         err = panic "[ERROR] Database.Flow.toInsert"
 

src/Gargantext/Database/Node/Document/Insert.hs

@@ -48,7 +48,6 @@ the concatenation of the parameters defined by @hashParameters@.
 
 -}
 ------------------------------------------------------------------------
-{-# LANGUAGE DeriveDataTypeable   #-}
 {-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE NoImplicitPrelude    #-}
@@ -62,15 +61,13 @@ module Gargantext.Database.Node.Document.Insert where
 import Control.Lens (set, view)
 import Control.Lens.Prism
 import Control.Lens.Cons
-import Data.Aeson (toJSON, Value)
+import Data.Aeson (toJSON)
 import Data.Maybe (maybe)
 import Data.Text (Text)
-import Data.Typeable (Typeable)
 import Database.PostgreSQL.Simple (FromRow, Query, Only(..))
 import Database.PostgreSQL.Simple.FromRow (fromRow, field)
 import Database.PostgreSQL.Simple.SqlQQ
 import Database.PostgreSQL.Simple.ToField (toField, Action)
-import Database.PostgreSQL.Simple.ToRow (ToRow(..))
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 import GHC.Generics (Generic)
 import Gargantext.Database.Config (nodeTypeId)
@@ -111,7 +108,11 @@ import Database.PostgreSQL.Simple (formatQuery)
 -- ParentId : folder ID which is parent of the inserted documents
 
 
-data ToDbData = ToDbDocument HyperdataDocument | ToDbContact HyperdataContact
+
+insertDb :: InsertDb a => UserId -> ParentId -> [a] -> Cmd err [ReturnId]
+insertDb u p = runPGSQuery queryInsert . Only . Values fields . map (insertDb' u p)
+      where
+        fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
 
 class InsertDb a
   where
@@ -127,64 +128,16 @@ instance InsertDb HyperdataDocument
                       , (toField . toJSON) h
                       ]
 
-insertDb :: InsertDb a => UserId -> ParentId -> [a] -> Cmd err [ReturnId]
-insertDb u p = runPGSQuery queryInsert . Only . Values fields . map (insertDb' u p)
-      where
-        fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
-
-
--- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
--- TODO-EVENTS: InsertedNodes
-insertDocuments :: UserId -> ParentId -> NodeType -> [ToDbData] -> Cmd err [ReturnId]
-insertDocuments uId pId nodeType =
-    runPGSQuery queryInsert . Only . Values fields . prepare uId pId nodeType
+instance InsertDb HyperdataContact
   where
-    fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
-
-
-
--- ** Insert Types
-data InputData = InputData { inTypenameId :: NodeTypeId
-                           , inUserId     :: UserId
-                           , inParentId   :: ParentId
-                           , inName       :: Text
-                           , inHyper      :: Value
-                           } deriving (Show, Generic, Typeable)
-
-instance ToRow InputData where
-  toRow inputData = [ toField (inTypenameId inputData)
-                    , toField (inUserId     inputData)
-                    , toField (inParentId   inputData)
-                    , toField (inName       inputData)
-                    , toField (inHyper      inputData)
+    insertDb' u p h = [ toField $ nodeTypeId NodeContact
+                      , toField u
+                      , toField p
+                      , toField $ maybe "Contact" (DT.take 255) (Just "Name") -- (_hc_name h)
+                      , (toField . toJSON) h
                       ]
 
 
-
-{-
-insertDocuments' :: CanInsertDb a => UserId -> ParentId -> a -> Cmd err [ReturnId]
-insertDocuments' uId pId as =
-    runPGSQuery queryInsert . Only . (Values $ fields as)
-  where
-    fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
---}
-
-prepare :: UserId -> ParentId -> NodeType -> [ToDbData] -> [InputData]
-prepare uId pId nodeType = map (\h -> InputData tId uId pId (name h) (toJSON' h))
-  where
-    tId    = nodeTypeId nodeType
-    
-    toJSON' (ToDbDocument hd) = toJSON hd
-    toJSON' (ToDbContact  hc) = toJSON hc
-    
-    name h = DT.take 255 <$> maybe "No Title" identity $ f h
-      where
-        f (ToDbDocument hd) = _hyperdataDocument_title hd
-        f (ToDbContact  _ ) = Just "Contact" -- TODO view FirstName . LastName
-
-
-
-
 -- | Debug SQL function
 --
 -- to print rendered query (Debug purpose) use @formatQuery@ function.
@@ -251,45 +204,49 @@ class AddUniqId a
 instance AddUniqId HyperdataDocument
   where
     addUniqId = addUniqIdsDoc
-
-addUniqIdsDoc :: HyperdataDocument -> HyperdataDocument
-addUniqIdsDoc doc = set hyperdataDocument_uniqIdBdd (Just hashBdd)
+      where
+        addUniqIdsDoc :: HyperdataDocument -> HyperdataDocument
+        addUniqIdsDoc doc = set hyperdataDocument_uniqIdBdd (Just hashBdd)
                           $ set hyperdataDocument_uniqId    (Just hashUni) doc
           where
             hashUni = hash $ DT.concat $ map ($ doc) hashParametersDoc
-    hashBdd = hash $ DT.concat $ map ($ doc) ([(\d -> maybe' (_hyperdataDocument_bdd d))] <> hashParametersDoc)
+            hashBdd = hash $ DT.concat $ map ($ doc) ([(\d -> maybeText (_hyperdataDocument_bdd d))] <> hashParametersDoc)
 
-
-hashParametersDoc :: [(HyperdataDocument -> Text)]
-hashParametersDoc = [ \d -> maybe' (_hyperdataDocument_title    d)
-                    , \d -> maybe' (_hyperdataDocument_abstract d)
-                    , \d -> maybe' (_hyperdataDocument_source   d)
-                    , \d -> maybe' (_hyperdataDocument_publication_date   d)
+        hashParametersDoc :: [(HyperdataDocument -> Text)]
+        hashParametersDoc = [ \d -> maybeText (_hyperdataDocument_title    d)
+                            , \d -> maybeText (_hyperdataDocument_abstract d)
+                            , \d -> maybeText (_hyperdataDocument_source   d)
+                            , \d -> maybeText (_hyperdataDocument_publication_date   d)
                             ]
----------------------------------------------------------------------------
+
+    ---------------------------------------------------------------------------
 -- * Uniqueness of document definition
 -- TODO factorize with above (use the function below for tests)
+
+instance AddUniqId HyperdataContact
+  where
+    addUniqId = addUniqIdsContact
+
 addUniqIdsContact :: HyperdataContact -> HyperdataContact
 addUniqIdsContact hc = set (hc_uniqIdBdd) (Just hashBdd)
                      $ set (hc_uniqId   ) (Just hashUni) hc
   where
     hashUni = uniqId $ DT.concat $ map ($ hc) hashParametersContact
-    hashBdd = uniqId $ DT.concat $ map ($ hc) ([\d -> maybe' (view hc_bdd d)] <> hashParametersContact)
+    hashBdd = uniqId $ DT.concat $ map ($ hc) ([\d -> maybeText (view hc_bdd d)] <> hashParametersContact)
 
     uniqId :: Text -> Text
     uniqId = DT.pack . SHA.showDigest . SHA.sha256 . DC.pack . DT.unpack
 
--- | TODO add more hashparameters
-hashParametersContact :: [(HyperdataContact -> Text)]
-hashParametersContact = [ \d -> maybe' $ view (hc_who . _Just . cw_firstName) d
-                        , \d -> maybe' $ view (hc_who . _Just . cw_lastName ) d
-                        , \d -> maybe' $ view (hc_where . _head . cw_touch . _Just . ct_mail) d
+    -- | TODO add more hashparameters
+    hashParametersContact :: [(HyperdataContact -> Text)]
+    hashParametersContact = [ \d -> maybeText $ view (hc_who . _Just . cw_firstName) d
+                            , \d -> maybeText $ view (hc_who . _Just . cw_lastName ) d
+                            , \d -> maybeText $ view (hc_where . _head . cw_touch . _Just . ct_mail) d
                             ]
 
 
 
-maybe' :: Maybe Text -> Text
-maybe' = maybe (DT.pack "") identity
+maybeText :: Maybe Text -> Text
+maybeText = maybe (DT.pack "") identity
 
 ---------------------------------------------------------------------------
-