[refactoring] rewrite for better record syntax

package.yaml

@@ -22,9 +22,11 @@ default-extensions:
   - FlexibleInstances
   - GeneralizedNewtypeDeriving
   - MultiParamTypeClasses
+  - NamedFieldPuns
   - NoImplicitPrelude
   - OverloadedStrings
   - RankNTypes
+  - RecordWildCards
 library:
   source-dirs: src
   ghc-options:

src/Gargantext/API.hs

@@ -59,7 +59,7 @@ import System.IO (FilePath)
 
 
 data Mode = Dev | Mock | Prod 
-       deriving (Show, Read, Generic)
+  deriving (Show, Read, Generic)
 
 -- | startGargantext takes as parameters port number and Ini file.
 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()

src/Gargantext/API/Node/Corpus/Searx.hs

-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Gargantext.API.Node.Corpus.Searx where

src/Gargantext/API/Search.hs

@@ -10,7 +10,6 @@ Portability : POSIX
 Count API part of Gargantext.
 -}
 
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeOperators      #-}
 {-# LANGUAGE DeriveAnyClass     #-}

src/Gargantext/Core/Ext/IMT.hs

@@ -33,73 +33,74 @@ data School = School { school_shortName :: Text
 
 schools :: [School]
 schools = [ School
-            ("Mines Albi-Carmaux")
-            ("Mines Albi-Carmaux - École nationale supérieure des Mines d'Albi‐Carmaux")
-            ("469216")
+            { school_shortName = "Mines Albi-Carmaux"
+            , school_longName = "Mines Albi-Carmaux - École nationale supérieure des Mines d'Albi‐Carmaux"
+            , school_id = "469216" }
           , School
-            ("Mines Alès")
-            ("EMA - École des Mines d'Alès")
-            ("6279")
+            { school_shortName = "Mines Alès"
+            , school_longName = "EMA - École des Mines d'Alès"
+            , school_id = "6279" }
           , School
-            ("Mines Douai")
-            ("Mines Douai EMD - École des Mines de Douai")
-            ("224096")
+            { school_shortName = "Mines Douai"
+            , school_longName = "Mines Douai EMD - École des Mines de Douai"
+            , school_id = "224096" }
           , School
-            ("Mines Lille")
-            ("Mines Lille - École des Mines de Lille")
-            ("144103")
+            { school_shortName = "Mines Lille"
+            , school_longName = "Mines Lille - École des Mines de Lille"
+            , school_id = "144103" }
           , School
-            ("IMT Lille Douai")
-            ("IMT Lille Douai")
-            ("497330")
+            { school_shortName = "IMT Lille Douai"
+            , school_longName = "IMT Lille Douai"
+            , school_id = "497330" }
           , School
-            ("Mines Nantes")
-            ("Mines Nantes - Mines Nantes")
-            ("84538")
+            { school_shortName = "Mines Nantes"
+            , school_longName = "Mines Nantes - Mines Nantes"
+            , school_id = "84538" }
           , School
-            ("Télécom Bretagne")
-            ("Télécom Bretagne")
-            ("301262")
+            { school_shortName = "Télécom Bretagne"
+            , school_longName = "Télécom Bretagne"
+            , school_id = "301262" }
           , School
-            ("IMT Atlantique")
-            ("IMT Atlantique - IMT Atlantique Bretagne-Pays de la Loire")
-            ("481355")
+            { school_shortName = "IMT Atlantique"
+            , school_longName = "IMT Atlantique - IMT Atlantique Bretagne-Pays de la Loire"
+            , school_id = "481355" }
           , School
-            ("Mines Saint-Étienne")
-            ("Mines Saint-Étienne MSE - École des Mines de Saint-Étienne")
-            ("29212")
+            { school_shortName = "Mines Saint-Étienne"
+            , school_longName = "Mines Saint-Étienne MSE - École des Mines de Saint-Étienne"
+            , school_id = "29212" }
           , School
-            ("Télécom École de Management")
-            ("TEM - Télécom Ecole de Management")
-            ("301442")
+            { school_shortName = "Télécom École de Management"
+            , school_longName = "TEM - Télécom Ecole de Management"
+            , school_id = "301442" }
           , School
-            ("IMT Business School")
-            ("IMT Business School")
-            ("542824")
+            { school_shortName = "IMT Business School"
+            , school_longName = "IMT Business School"
+            , school_id = "542824" }
           , School
-            ("Télécom ParisTech")
-            ("Télécom ParisTech")
-            ("300362")
+            { school_shortName = "Télécom ParisTech"
+            , school_longName = "Télécom ParisTech"
+            , school_id = "300362" }
           , School
-            ("Télécom SudParis")
-            ("TSP - Télécom SudParis")
-            ("352124")
+            { school_shortName = "Télécom SudParis"
+            , school_longName = "TSP - Télécom SudParis"
+            , school_id = "352124" }
           , School
-            ("ARMINES")
-            ("ARMINES")
-            ("300362")
+            { school_shortName = "ARMINES"
+            , school_longName = "ARMINES"
+            , school_id = "300362" }
           , School
-            ("Eurecom")
-            ("Eurecom")
-            ("421532")
+            { school_shortName = "Eurecom"
+            , school_longName = "Eurecom"
+            , school_id = "421532" }
           , School
-            ("Mines ParisTech")
-            ("MINES ParisTech - École nationale supérieure des mines de Paris")
-            ("301492")
+            { school_shortName = "Mines ParisTech"
+            , school_longName = "MINES ParisTech - École nationale supérieure des mines de Paris"
+            , school_id = "301492" }
             ]
 
 mapIdSchool :: Map Text Text
-mapIdSchool = M.fromList $ Gargantext.Prelude.map (\(School n _ i) -> (i,n)) schools
+mapIdSchool = M.fromList $ Gargantext.Prelude.map
+                (\(School { school_shortName, school_id }) -> (school_id, school_shortName)) schools
 
 hal_data :: IO (Either Prelude.String (DV.Vector CsvHal))
 hal_data = do

src/Gargantext/Core/Ext/IMTUser.hs

@@ -75,37 +75,39 @@ data IMTUser = IMTUser
 
 -- | CSV instance
 instance FromNamedRecord IMTUser where
-  parseNamedRecord r = IMTUser <$> r .: "id"
-                               <*> r .: "entite"
-                               <*> r .: "mail"
-                               <*> r .: "nom"
-                               <*> r .: "prenom"
-                               <*> r .: "fonction"
-                               <*> r .: "fonction2"
-                               <*> r .: "tel"
-                               <*> r .: "fax"
-                               <*> r .: "service"
-                               <*> r .: "groupe"
-                               <*> r .: "entite2"
-                               <*> r .: "service2"
-                               <*> r .: "groupe2"
-                               <*> r .: "bureau"
-                               <*> r .: "url"
-                               <*> r .: "pservice"
-                               <*> r .: "pfonction"
-                               <*> r .: "afonction"
-                               <*> r .: "afonction2"
-                               <*> r .: "grprech"
-                               <*> r .: "appellation"
-                               <*> r .: "lieu"
-                               <*> r .: "aprecision"
-                               <*> r .: "atel"
-                               <*> r .: "sexe"
-                               <*> r .: "statut"
-                               <*> r .: "idutilentite"
-                               <*> r .: "actif"
-                               <*> r .: "idutilsiecoles"
-                               <*> r .: "date_modification"
+  parseNamedRecord r = do
+    id <- r .: "id"
+    entite <- r .: "entite"
+    mail <- r .: "mail"
+    nom <- r .: "nom"
+    prenom <- r .: "prenom"
+    fonction <- r .: "fonction"
+    fonction2 <- r .: "fonction2"
+    tel <- r .: "tel"
+    fax <- r .: "fax"
+    service <- r .: "service"
+    groupe <- r .: "groupe"
+    entite2 <- r .: "entite2"
+    service2 <- r .: "service2"
+    groupe2 <- r .: "groupe2"
+    bureau <- r .: "bureau"
+    url <- r .: "url"
+    pservice <- r .: "pservice"
+    pfonction <- r .: "pfonction"
+    afonction <- r .: "afonction"
+    afonction2 <- r .: "afonction2"
+    grprech <- r .: "grprech"
+    appellation <- r .: "appellation"
+    lieu <- r .: "lieu"
+    aprecision <- r .: "aprecision"
+    atel <- r .: "atel"
+    sexe <- r .: "sexe"
+    statut <- r .: "statut"
+    idutilentite <- r .: "idutilentite"
+    actif <- r .: "actif"
+    idutilsiecoles <- r .: "idutilsiecoles"
+    date_modification <- r .: "date_modification"
+    pure $ IMTUser {..}
 
 headerCSVannuaire :: Header
 headerCSVannuaire =
@@ -136,15 +138,54 @@ deserialiseFromFile' filepath = deserialise <$> BL.readFile filepath
 
 ------------------------------------------------------------------------
 imtUser2gargContact :: IMTUser -> HyperdataContact
-imtUser2gargContact (IMTUser id' entite' mail' nom' prenom' fonction' _fonction2' tel' _fax'
-                     service' _groupe' _entite2 _service2 _group2 bureau' url' _pservice' _pfonction' _afonction' _afonction2'
-                     _grprech' _appellation' lieu' _aprecision' _atel' _sexe' _statut' _idutilentite'
-                     _actif' _idutilsiecoles' date_modification')
-                  = HyperdataContact (Just "IMT Annuaire") (Just qui) [ou] ((<>) <$> (fmap (\p -> p <> " ") prenom') <*> nom') entite' date_modification' Nothing Nothing
-                    where
-                      qui = ContactWho id' prenom' nom' (catMaybes [service']) []
-                      ou  = ContactWhere (toList entite') (toList service') fonction' bureau' (Just "France") lieu' contact Nothing Nothing
-                      contact = Just $ ContactTouch mail' tel' url'
-                      -- meta    = ContactMetaData (Just "IMT annuaire") date_modification'
-                      toList Nothing  = []
-                      toList (Just x) = [x]
+--imtUser2gargContact (IMTUser id' entite' mail' nom' prenom' fonction' _fonction2' tel' _fax'
+--                     service' _groupe' _entite2 _service2 _group2 bureau' url' _pservice' _pfonction' _afonction' _afonction2'
+--                     _grprech' _appellation' lieu' _aprecision' _atel' _sexe' _statut' _idutilentite'
+--                     _actif' _idutilsiecoles' date_modification')
+--                  = HyperdataContact (Just "IMT Annuaire") (Just qui) [ou] ((<>) <$> (fmap (\p -> p <> " ") prenom') <*> nom') entite' date_modification' Nothing Nothing
+imtUser2gargContact (IMTUser { id
+                             , entite
+                             , mail
+                             , nom
+                             , prenom
+                             , fonction
+                             , tel
+                             , service
+                             , bureau
+                             , url
+                             , lieu
+                             , date_modification }) =
+                        HyperdataContact { _hc_bdd = Just "IMT Annuaire"
+                                         , _hc_who = Just qui
+                                         , _hc_where = [ou]
+                                         , _hc_title = title
+                                         , _hc_source = entite
+                                         , _hc_lastValidation = date_modification
+                                         , _hc_uniqIdBdd = Nothing
+                                         , _hc_uniqId = Nothing }
+  where
+    title = (<>) <$> (fmap (\p -> p <> " ") prenom) <*> nom
+    qui = ContactWho { _cw_id = id
+                     , _cw_firstName = prenom
+                     , _cw_lastName = nom
+                     , _cw_keywords = catMaybes [service]
+                     , _cw_freetags = [] }
+    ou  = ContactWhere { _cw_organization = toList entite
+                       , _cw_labTeamDepts = toList service
+                       , _cw_role = fonction
+                       , _cw_office = bureau
+                       , _cw_country = Just "France"
+                       , _cw_city = lieu
+                       , _cw_touch = contact
+                       , _cw_entry = Nothing
+                       , _cw_exit = Nothing }
+    contact = Just $ ContactTouch { _ct_mail = mail
+                                  , _ct_phone = tel
+                                  , _ct_url = url }
+    -- meta    = ContactMetaData (Just "IMT annuaire") date_modification'
+    toList Nothing  = []
+    toList (Just x) = [x]
+  
+
+
+

src/Gargantext/Core/Methods/Distances.hs

@@ -50,3 +50,6 @@ instance Arbitrary GraphMetric where
   arbitrary = elements [ minBound .. maxBound ]
 
 ------------------------------------------------------------------------
+
+
+

src/Gargantext/Core/NodeStory.hs

@@ -82,7 +82,9 @@ readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
 readNodeStoryEnv nsd = do
   mvar  <- nodeStoryVar nsd Nothing [0]
   saver <- mkNodeStorySaver nsd mvar
-  pure $ NodeStoryEnv mvar saver (nodeStoryVar nsd (Just mvar))
+  pure $ NodeStoryEnv { _nse_var = mvar
+                      , _nse_saver = saver
+                      , _nse_getter = nodeStoryVar nsd (Just mvar) }
 
 ------------------------------------------------------------------------
 mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
@@ -212,7 +214,9 @@ repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
     h' = ngramsStatePatch_migration h
     ns = List.map (\(n,ns')
                     -> (n, let hs = fromMaybe [] (Map.lookup n h') in
-                               Archive (List.length hs) ns' hs
+                               Archive { _a_version = List.length hs
+                                       , _a_state = ns'
+                                       , _a_history = hs }
                        )
                   ) $ Map.toList s'
 
@@ -276,10 +280,17 @@ instance Serialise NgramsStatePatch'
 -- TODO Semigroup instance for unions
 -- TODO check this
 instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
-  (<>) (Archive _v _s p) (Archive v' s' p') = Archive v' s' (p' <> p)
+  (<>) (Archive { _a_history = p }) (Archive { _a_version = v'
+                                             , _a_state = s'
+                                             , _a_history = p'}) =
+    Archive { _a_version = v'
+            , _a_state = s'
+            , _a_history = p' <> p }
 
 instance Monoid (Archive NgramsState' NgramsStatePatch') where
-  mempty = Archive 0 mempty []
+  mempty = Archive { _a_version = 0
+                   , _a_state = mempty
+                   , _a_history = [] }
 
 instance (FromJSON s, FromJSON p) => FromJSON (Archive s p) where
   parseJSON = genericParseJSON $ unPrefix "_a_"
@@ -293,13 +304,17 @@ initNodeStory :: Monoid s => NodeId -> NodeStory s p
 initNodeStory ni = NodeStory $ Map.singleton ni initArchive
 
 initArchive :: Monoid s => Archive s p
-initArchive = Archive 0 mempty []
+initArchive = Archive { _a_version = 0
+                      , _a_state = mempty
+                      , _a_history = [] }
 
 initNodeListStoryMock :: NodeListStory
 initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
   where
     nodeListId = 0
-    archive        = Archive 0 ngramsTableMap []
+    archive        = Archive { _a_version = 0
+                             , _a_state = ngramsTableMap
+                             , _a_history = [] }
     ngramsTableMap = Map.singleton TableNgrams.NgramsTerms
                    $ Map.fromList
                    [ (n ^. ne_ngrams, ngramsElementToRepo n)

src/Gargantext/Core/Text/List/Social/Patch.hs

@@ -70,9 +70,11 @@ Children are not modified in this specific case.
 -- | Old list get -1 score
 -- New list get +1 score
 -- Hence others lists lay around 0 score
-addScorePatch fl (t, (NgramsPatch children' (Patch.Replace old_list new_list))) =
+addScorePatch fl (t, (NgramsPatch { _patch_children
+                                  , _patch_list = Patch.Replace old_list new_list })) =
   -- Adding new 'Children' score
-  addScorePatch fl' (t, NgramsPatch children' Patch.Keep)
+  addScorePatch fl' (t, NgramsPatch { _patch_children
+                                    , _patch_list = Patch.Keep })
     where
       -- | Adding new 'ListType' score
       fl' = fl & flc_scores . at t %~ (score fls_listType old_list (-1))
@@ -80,8 +82,9 @@ addScorePatch fl (t, (NgramsPatch children' (Patch.Replace old_list new_list)))
           & flc_cont   %~ (HashMap.delete t)
 
 -- | Patching existing Ngrams with children
-addScorePatch fl (p, NgramsPatch children' Patch.Keep) =
-  foldl' addChild fl $ patchMSet_toList children'
+addScorePatch fl (p, NgramsPatch { _patch_children
+                                 , _patch_list = Patch.Keep }) =
+  foldl' addChild fl $ patchMSet_toList _patch_children
     where
       -- | Adding a child
       addChild fl' (t, Patch.Replace Nothing (Just _)) = doLink ( 1) p t fl'
@@ -92,20 +95,24 @@ addScorePatch fl (p, NgramsPatch children' Patch.Keep) =
       addChild fl' _ = fl'
 
 -- | Inserting a new Ngrams
-addScorePatch fl (t, NgramsReplace Nothing (Just nre)) =
+addScorePatch fl (t, NgramsReplace { _patch_old = Nothing
+                                   , _patch_new = Just nre }) =
   childrenScore 1 t (nre ^. nre_children) 
   $ fl & flc_scores . at t %~ (score fls_listType $ nre ^. nre_list) 1
        & flc_cont   %~ (HashMap.delete t)
 
-addScorePatch fl (t, NgramsReplace (Just old_nre) maybe_new_nre) =
+addScorePatch fl (t, NgramsReplace { _patch_old = Just old_nre
+                                   , _patch_new = maybe_new_nre }) =
   let fl' = childrenScore (-1) t (old_nre ^. nre_children) 
             $ fl & flc_scores . at t %~ (score fls_listType $ old_nre ^. nre_list) (-1)
                  & flc_cont   %~ (HashMap.delete t)
     in case maybe_new_nre of
       Nothing      -> fl'
-      Just new_nre -> addScorePatch fl' (t, NgramsReplace Nothing (Just new_nre))
+      Just new_nre -> addScorePatch fl' (t, NgramsReplace { _patch_old = Nothing
+                                                          , _patch_new = Just new_nre })
 
-addScorePatch fl (_, NgramsReplace Nothing Nothing) = fl
+addScorePatch fl (_, NgramsReplace { _patch_old = Nothing
+                                   , _patch_new = Nothing }) = fl
 
 -------------------------------------------------------------------------------
 -- | Utils

src/Gargantext/Core/Text/Search.hs

@@ -13,8 +13,6 @@ Starting from this model, a specific Gargantext engine will be made
 (using more metrics scores/features).
 -}
 
-{-# LANGUAGE NamedFieldPuns #-}
-
 module Gargantext.Core.Text.Search where
 
 import Data.SearchEngine