MonadBase replaces MonadIO

bin/gargantext-import/Main.hs

@@ -37,7 +37,6 @@ import System.Environment (getArgs)
 --import Gargantext.Text.Corpus.Parsers.GrandDebat (readFile, GrandDebatReference(..))
 import Data.Text (Text)
 import qualified Data.Text as Text
-import Control.Monad.IO.Class (liftIO)
 
 main :: IO ()
 main = do

src/Gargantext/API.hs

@@ -51,7 +51,6 @@ import Control.Concurrent (threadDelay)
 import Control.Exception (finally)
 import Control.Lens
 import Control.Monad.Except (withExceptT, ExceptT)
-import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Reader (ReaderT, runReaderT)
 import Data.Aeson.Encode.Pretty (encodePretty)
 import Data.Swagger
@@ -235,7 +234,7 @@ waitAPI ::  Int -> GargServer WaitAPI
 waitAPI n = do
   let
     m = (10 :: Int) ^ (6 :: Int)
-  _ <- liftIO $ threadDelay ( m * n)
+  _ <- liftBase $ threadDelay ( m * n)
   pure $ "Waited: " <> (cs $ show n)
 ----------------------------------------
 
@@ -418,19 +417,19 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
 
 {-
 addUpload :: GargServer New.Upload
-addUpload cId = (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftIO . log)))
-           :<|> (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusWithForm    cid i (liftIO . log)))
+addUpload cId = (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftBase . log)))
+           :<|> (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusWithForm    cid i (liftBase . log)))
 --}
 
 addCorpusWithQuery :: GargServer New.AddWithQuery
 addCorpusWithQuery cid =
   serveJobsAPI $
-    JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftIO . log))
+    JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftBase . log))
 
 addWithFile :: GargServer New.AddWithFile
 addWithFile cid i f =
   serveJobsAPI $
-    JobFunction (\_i log -> New.addToCorpusWithFile cid i f (liftIO . log))
+    JobFunction (\_i log -> New.addToCorpusWithFile cid i f (liftBase . log))
 
 addCorpusWithForm :: Text -> GargServer New.AddWithForm
 addCorpusWithForm username cid =
@@ -439,19 +438,19 @@ addCorpusWithForm username cid =
       let
         log' x = do
           printDebug "addCorpusWithForm" x
-          liftIO $ log x
+          liftBase $ log x
       in New.addToCorpusWithForm username cid i log')
 
 addAnnuaireWithForm :: GargServer Annuaire.AddWithForm
 addAnnuaireWithForm cid =
   serveJobsAPI $
-    JobFunction (\i log -> Annuaire.addToAnnuaireWithForm cid i (liftIO . log))
+    JobFunction (\i log -> Annuaire.addToAnnuaireWithForm cid i (liftBase . log))
 
 {-
 serverStatic :: Server (Get '[HTML] Html)
 serverStatic = $(do
                   let path = "purescript-gargantext/dist/index.html"
-                  Just s <- liftIO (fileTypeToFileTree (FileTypeFile path))
+                  Just s <- liftBase (fileTypeToFileTree (FileTypeFile path))
                   fileTreeToServer s
                 )
 -}

src/Gargantext/API/Annuaire.hs

@@ -88,7 +88,7 @@ addToAnnuaireWithForm _cid (WithForm ft _d _l) logStatus = do
     --   WOS       -> Parser.parseFormat Parser.WOS
     --   PresseRIS -> Parser.parseFormat Parser.RisPresse
 
-  -- docs <- liftIO
+  -- docs <- liftBase
   --       $ splitEvery 500
   --      <$> take 1000000
   --      <$> parse (cs d)

src/Gargantext/API/Auth.hs

@@ -33,7 +33,6 @@ module Gargantext.API.Auth
       where
 
 import Control.Lens (view)
-import Control.Monad.IO.Class (liftIO)
 import Data.Aeson.TH (deriveJSON)
 import Data.List (elem)
 import Data.Swagger
@@ -91,7 +90,7 @@ makeTokenForUser :: (HasSettings env, HasJoseError err)
                  => NodeId -> Cmd' env err Token
 makeTokenForUser uid = do
   jwtS <- view $ settings . jwtSettings
-  e <- liftIO $ makeJWT (AuthenticatedUser uid) jwtS Nothing
+  e <- liftBase $ makeJWT (AuthenticatedUser uid) jwtS Nothing
   -- TODO-SECURITY here we can implement token expiration ^^.
   either joseError (pure . toStrict . decodeUtf8) e
   -- TODO not sure about the encoding...

src/Gargantext/API/Corpus/New.hs

@@ -27,7 +27,6 @@ module Gargantext.API.Corpus.New
 
 --import Gargantext.Text.Corpus.Parsers (parseFile, FileFormat(..))
 import Control.Lens hiding (elements)
-import Control.Monad.IO.Class (liftIO)
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import Data.Maybe (fromMaybe)
@@ -95,7 +94,7 @@ api _uId (Query q _ as) = do
     Nothing      -> flowCorpusSearchInDatabase "user1" EN q
     Just API.All -> flowCorpusSearchInDatabase "user1" EN q
     Just a   -> do
-      docs <- liftIO $ API.get a q (Just 1000)
+      docs <- liftBase $ API.get a q (Just 1000)
       cId' <- flowCorpus "user1" (Left q) (Multi EN) [docs]
       pure cId'
 
@@ -234,10 +233,10 @@ addToCorpusWithForm' :: FlowCmdM env err m
                     -> (ScraperStatus -> m ())
                     -> m ScraperStatus
 addToCorpusWithForm' cid (WithForm ft d l) logStatus = do
-  newStatus <- liftIO newEmptyMVar
+  newStatus <- liftBase newEmptyMVar
   s  <- addToCorpusWithForm cid (WithForm ft d l) logStatus
-  _  <- liftIO $ forkIO $ putMVar newStatus s
-  s' <- liftIO $ takeMVar newStatus
+  _  <- liftBase $ forkIO $ putMVar newStatus s
+  s' <- liftBase $ takeMVar newStatus
   pure s'
 -}
 addToCorpusWithForm :: FlowCmdM env err m
@@ -264,7 +263,7 @@ addToCorpusWithForm username cid (WithForm ft d l _n) logStatus = do
   printDebug "Parsing corpus: " cid
 
   -- TODO granularity of the logStatus
-  docs <- liftIO $ splitEvery 500
+  docs <- liftBase $ splitEvery 500
       <$> take 1000000
       <$> parse (cs d)
 

src/Gargantext/API/Corpus/New/File.hs

@@ -27,7 +27,6 @@ module Gargantext.API.Corpus.New.File
 
 import Control.Lens ((.~), (?~))
 import Control.Monad (forM)
-import Control.Monad.IO.Class (liftIO)
 import Data.Maybe
 import Data.Aeson
 import Data.Monoid (mempty)
@@ -100,18 +99,18 @@ postUpload :: NodeId
            -> Cmd err [Hash]
 postUpload _ Nothing _ = panic "fileType is a required parameter"
 postUpload _ (Just fileType) multipartData = do
-  putStrLn $ "File Type: " <> (show fileType)
-  is <- liftIO $ do
-    putStrLn ("Inputs:" :: Text)
+  printDebug "File Type: " fileType
+  is <- liftBase $ do
+    printDebug "Inputs:" ()
     forM (inputs multipartData) $ \input -> do
-      putStrLn $ ("iName  " :: Text) <> (iName input)
-               <> ("iValue " :: Text) <> (iValue input)
+      printDebug "iName  " (iName input)
+      printDebug "iValue " (iValue input)
       pure $ iName input
 
   _ <- forM (files multipartData) $ \file -> do
     let content = fdPayload file
-    putStrLn $ ("XXX " :: Text) <> (fdFileName file)
-    putStrLn $ ("YYY " :: Text) <>  cs content
+    printDebug "XXX " (fdFileName file)
+    printDebug "YYY " content
     --pure $ cs content
   -- is <- inputs multipartData
 

src/Gargantext/API/Ngrams.hs

@@ -119,6 +119,7 @@ import qualified Data.Set as Set
 import Control.Category ((>>>))
 import Control.Concurrent
 import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (.~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~), mapped)
+import Control.Monad.Base (MonadBase, liftBase)
 import Control.Monad.Error.Class (MonadError)
 import Control.Monad.Reader
 import Control.Monad.State
@@ -797,15 +798,14 @@ instance HasRepoSaver RepoEnv where
 type RepoCmdM   env err m =
   ( MonadReader env     m
   , MonadError      err m
-  , MonadIO             m -- TODO liftIO -> liftBase
   , MonadBaseControl IO m
   , HasRepo     env
   )
 ------------------------------------------------------------------------
 
-saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env )
+saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
          => m ()
-saveRepo = liftIO =<< view repoSaver
+saveRepo = liftBase =<< view repoSaver
 
 listTypeConflictResolution :: ListType -> ListType -> ListType
 listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
@@ -836,7 +836,7 @@ copyListNgrams :: RepoCmdM env err m
                -> m ()
 copyListNgrams srcListId dstListId ngramsType = do
   var <- view repoVar
-  liftIO $ modifyMVar_ var $
+  liftBase $ modifyMVar_ var $
     pure . (r_state . at ngramsType %~ (Just . f . something))
   saveRepo
   where
@@ -851,7 +851,7 @@ addListNgrams :: RepoCmdM env err m
               -> [NgramsElement] -> m ()
 addListNgrams listId ngramsType nes = do
   var <- view repoVar
-  liftIO $ modifyMVar_ var $
+  liftBase $ modifyMVar_ var $
     pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
   saveRepo
   where
@@ -873,7 +873,7 @@ setListNgrams ::  RepoCmdM env err m
               -> m ()
 setListNgrams listId ngramsType ns = do
   var <- view repoVar
-  liftIO $ modifyMVar_ var $
+  liftBase $ modifyMVar_ var $
     pure . ( r_state
            . at ngramsType %~
              (Just .
@@ -901,7 +901,7 @@ putListNgrams' :: RepoCmdM env err m
 putListNgrams' listId ngramsType ns = do
   -- printDebug "putListNgrams" (length nes)
   var <- view repoVar
-  liftIO $ modifyMVar_ var $
+  liftBase $ modifyMVar_ var $
     pure . ( r_state
            . at ngramsType %~
              (Just .
@@ -930,7 +930,7 @@ currentVersion :: RepoCmdM env err m
                => m Version
 currentVersion = do
   var <- view repoVar
-  r   <- liftIO $ readMVar var
+  r   <- liftBase $ readMVar var
   pure $ r ^. r_version
 
 tableNgramsPull :: RepoCmdM env err m
@@ -939,7 +939,7 @@ tableNgramsPull :: RepoCmdM env err m
                 -> m (Versioned NgramsTablePatch)
 tableNgramsPull listId ngramsType p_version = do
   var <- view repoVar
-  r <- liftIO $ readMVar var
+  r <- liftBase $ readMVar var
 
   let
     q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
@@ -968,7 +968,7 @@ tableNgramsPut tabType listId (Versioned p_version p_table)
       assertValid p_validity
 
       var <- view repoVar
-      vq' <- liftIO $ modifyMVar var $ \r -> do
+      vq' <- liftBase $ modifyMVar var $ \r -> do
         let
           q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
           (p', q') = transformWith ngramsStatePatchConflictResolution p q
@@ -1008,7 +1008,7 @@ getNgramsTableMap :: RepoCmdM env err m
                   -> m (Versioned NgramsTableMap)
 getNgramsTableMap nodeId ngramsType = do
   v    <- view repoVar
-  repo <- liftIO $ readMVar v
+  repo <- liftBase $ readMVar v
   pure $ Versioned (repo ^. r_version)
                    (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
 
@@ -1020,8 +1020,8 @@ type MaxSize = Int
 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
 -- TODO: should take only one ListId
 
-getTime' :: MonadIO m => m TimeSpec
-getTime' = liftIO $ getTime ProcessCPUTime
+getTime' :: MonadBase IO m => m TimeSpec
+getTime' = liftBase $ getTime ProcessCPUTime
 
 
 getTableNgrams :: forall env err m.
@@ -1087,7 +1087,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
                                             ngramsType
                                             ngrams_terms
       t2 <- getTime'
-      liftIO $ hprint stderr
+      liftBase $ hprint stderr
         ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
         (length ngrams_terms) t1 t2
       {-
@@ -1116,7 +1116,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
                                     . setScores (not scoresNeeded)
                                     . selectAndPaginate
   t3 <- getTime'
-  liftIO $ hprint stderr
+  liftBase $ hprint stderr
             ("getTableNgrams total=" % timeSpecs
                           % " map1=" % timeSpecs
                           % " map2=" % timeSpecs

src/Gargantext/API/Ngrams/List.hs

@@ -24,7 +24,6 @@ module Gargantext.API.Ngrams.List
   where
 
 import Control.Lens hiding (elements)
-import Control.Monad.IO.Class (liftIO)
 import Data.Aeson
 import Data.List (zip)
 import Data.Map (Map, toList, fromList)
@@ -111,7 +110,7 @@ type PostAPI = Summary "Update List"
 postAsync :: ListId -> GargServer PostAPI
 postAsync lId =
   serveJobsAPI $
-    JobFunction (\f  log' -> postAsync' lId f (liftIO . log'))
+    JobFunction (\f  log' -> postAsync' lId f (liftBase . log'))
 
 postAsync' :: FlowCmdM env err m
           => ListId

src/Gargantext/API/Ngrams/Tools.hs

@@ -37,7 +37,7 @@ type RootTerm = Text
 getRepo :: RepoCmdM env err m => m NgramsRepo
 getRepo = do
   v <- view repoVar
-  liftIO $ readMVar v
+  liftBase $ readMVar v
 
 listNgramsFromRepo :: [ListId] -> NgramsType
                    -> NgramsRepo -> Map Text NgramsRepoElement

src/Gargantext/Core/Types.hs

@@ -139,7 +139,7 @@ class HasInvalidError e where
 
 assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
 assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
+-- assertValid :: MonadBase IO m => Validation -> m ()
 -- assertValid v = when (not $ validationIsValid v) $ fail $ show v
 
 

src/Gargantext/Database/Flow.hs

@@ -44,7 +44,6 @@ import Data.Tuple.Extra (first, second)
 import Data.Traversable (traverse)
 import Debug.Trace (trace)
 import Control.Lens ((^.), view, _Just)
-import Control.Monad.IO.Class (liftIO)
 import Data.List (concat)
 import Data.Map (Map, lookup)
 import Data.Maybe (Maybe(..), catMaybes)
@@ -109,7 +108,7 @@ _flowCorpusApi :: ( FlowCmdM env err m)
                -> ApiQuery
                -> m CorpusId
 _flowCorpusApi u n tt l q = do
-  docs <- liftIO $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
+  docs <- liftBase $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
   flowCorpus u n tt docs
 
 ------------------------------------------------------------------------
@@ -121,7 +120,7 @@ flowAnnuaire :: FlowCmdM env err m
              -> FilePath
              -> m AnnuaireId
 flowAnnuaire u n l filePath = do
-  docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
+  docs <- liftBase $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
   flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
 
 -- UNUSED
@@ -130,7 +129,7 @@ _flowCorpusDebat :: FlowCmdM env err m
                  -> Limit -> FilePath
                  -> m CorpusId
 _flowCorpusDebat u n l fp = do
-  docs <- liftIO ( splitEvery 500
+  docs <- liftBase ( splitEvery 500
                  <$> take l
                  <$> readFile' fp
                  :: IO [[GD.GrandDebatReference ]]
@@ -143,7 +142,7 @@ flowCorpusFile :: FlowCmdM env err m
            -> TermType Lang -> FileFormat -> FilePath
            -> m CorpusId
 flowCorpusFile u n l la ff fp = do
-  docs <- liftIO ( splitEvery 500
+  docs <- liftBase ( splitEvery 500
                  <$> take l
                  <$> parseFile ff fp
                  )
@@ -439,7 +438,7 @@ instance ExtractNgramsT HyperdataDocument
           terms' <- map text2ngrams
                  <$> map (intercalate " " . _terms_label)
                  <$> concat
-                 <$> liftIO (extractTerms lang' $ hasText doc)
+                 <$> liftBase (extractTerms lang' $ hasText doc)
 
           pure $ Map.fromList $  [(source, Map.singleton Sources 1)]
                              <> [(i', Map.singleton Institutes  1) | i' <- institutes ]

src/Gargantext/Database/Flow/Annuaire.hs

@@ -29,7 +29,7 @@ import Gargantext.Database.Flow
 
 flowAnnuaire :: FlowCmdM env ServantErr m => FilePath -> m ()
 flowAnnuaire filePath = do
-  contacts <- liftIO $ deserialiseImtUsersFromFile filePath
+  contacts <- liftBase $ deserialiseImtUsersFromFile filePath
   ps <- flowInsertAnnuaire "Annuaire"
       $ map (\h-> ToDbContact h)
       $ map addUniqIdsContact contacts

src/Gargantext/Database/Utils.hs

@@ -61,12 +61,11 @@ instance HasConnectionPool (Pool Connection) where
 type CmdM' env err m =
   ( MonadReader env m
   , MonadError err m
-  , MonadIO m
+  , MonadBaseControl IO m
   )
 
 type CmdM env err m =
   ( CmdM' env err m
-  , MonadBaseControl IO m
   , HasConnectionPool env
   )
 
@@ -81,7 +80,7 @@ fromInt64ToInt = fromIntegral
 mkCmd :: (Connection -> IO a) -> Cmd err a
 mkCmd k = do
   pool <- view connPool
-  withResource pool (liftIO . k)
+  withResource pool (liftBase . k)
 
 runCmd :: (HasConnectionPool env)
        => env -> Cmd' env err a
@@ -106,7 +105,7 @@ runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 
 runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
-                PGS.FromRow r, PGS.ToRow q, MonadIO m, HasConnectionPool env)
+                PGS.FromRow r, PGS.ToRow q, HasConnectionPool env)
                 => PGS.Query -> q -> m [r]
 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
   where

src/Gargantext/Prelude.hs

@@ -12,6 +12,7 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults  #-}
 
+{-# LANGUAGE     FlexibleContexts        #-}
 {-# LANGUAGE     NoImplicitPrelude       #-}
 {-# LANGUAGE     OverloadedStrings       #-}
 {-# LANGUAGE     RankNTypes              #-}
@@ -28,11 +29,11 @@ module Gargantext.Prelude
   , round
   , sortWith
   , module Prelude
+  , MonadBase(..)
   )
   where
 
-import Control.Monad.IO.Class (liftIO, MonadIO)
-import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO)
+import Control.Monad.Base (MonadBase(..))
 import GHC.Exts (sortWith)
 import GHC.Err.Located (undefined)
 import GHC.Real (round)
@@ -43,7 +44,6 @@ import Protolude ( Bool(True, False), Int, Int64, Double, Integer
                  , Enum, Bounded, Float
                  , Floating, Char, IO
                  , pure, (>>=), (=<<), (<*>), (<$>), (>>)
-                 , putStrLn
                  , head, flip
                  , Ord, Integral, Foldable, RealFrac, Monad, filter
                  , reverse, map, mapM, zip, drop, take, zipWith
@@ -63,7 +63,7 @@ import Protolude ( Bool(True, False), Int, Int64, Double, Integer
                  , panic
                  )
 
-import Prelude (Enum, Bounded, minBound, maxBound)
+import Prelude (Enum, Bounded, minBound, maxBound, putStrLn)
 -- TODO import functions optimized in Utils.Count
 -- import Protolude hiding (head, last, all, any, sum, product, length)
 -- import Gargantext.Utils.Count
@@ -81,8 +81,8 @@ import Text.Read (Read())
 import Data.String.Conversions (cs)
 
 
-printDebug :: (Show a, MonadIO m) => [Char] -> a -> m ()
-printDebug msg x = putStrLn $ msg <> " " <> show x
+printDebug :: (Show a, MonadBase IO m) => [Char] -> a -> m ()
+printDebug msg x = liftBase . putStrLn $ msg <> " " <> show x
 -- printDebug _ _ = pure ()
 
 

src/Gargantext/Prelude/Utils.hs

@@ -9,6 +9,7 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE     FlexibleContexts        #-}
 {-# LANGUAGE     NoImplicitPrelude       #-}
 {-# LANGUAGE     OverloadedStrings       #-}
 
@@ -17,7 +18,6 @@ module Gargantext.Prelude.Utils
 
 import Control.Lens (view)
 import Control.Monad.Reader (MonadReader)
-import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Random.Class (MonadRandom)
 import Data.Text (Text)
 import Control.Monad.Reader (ask)
@@ -84,23 +84,23 @@ class ReadFile a where
   readFile' :: FilePath -> IO a
 
 
-writeFile :: (MonadReader env m, MonadIO m, HasSettings env, SaveFile a)
+writeFile :: (MonadReader env m, MonadBase IO m, HasSettings env, SaveFile a)
          => a -> m FilePath
 writeFile a = do
   dataPath <- view (settings . fileFolder) <$> ask
-  (fp,fn)  <- liftIO $ (toPath 3) . sha . Text.pack . show <$> newStdGen
+  (fp,fn)  <- liftBase $ (toPath 3) . sha . Text.pack . show <$> newStdGen
   
   let foldPath = dataPath <> "/" <> fp
       filePath = foldPath <> "/" <> fn
   
-  _ <- liftIO $ createDirectoryIfMissing True foldPath
-  _ <- liftIO $ saveFile' filePath a
+  _ <- liftBase $ createDirectoryIfMissing True foldPath
+  _ <- liftBase $ saveFile' filePath a
   
   pure filePath
 
 
-readFile :: (MonadReader env m, MonadIO m, HasSettings env, ReadFile a)
+readFile :: (MonadReader env m, MonadBase IO m, HasSettings env, ReadFile a)
          => FilePath -> m a
 readFile fp = do
   dataPath <- view (settings . fileFolder) <$> ask
-  liftIO $ readFile' $ dataPath <> "/" <> fp
+  liftBase $ readFile' $ dataPath <> "/" <> fp

src/Gargantext/Text/List.hs

@@ -9,6 +9,7 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}

src/Gargantext/Text/List/Learn.hs

@@ -13,6 +13,7 @@ CSV parser for Gargantext corpus files.
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -20,7 +21,6 @@ module Gargantext.Text.List.Learn
   where
 
 import Control.Monad.Reader (MonadReader)
-import Control.Monad.IO.Class (MonadIO, liftIO)
 import Gargantext.API.Settings
 import Data.Map (Map)
 import Data.Maybe (maybe)
@@ -87,18 +87,18 @@ type Tests = Map ListType [Vec.Vector Double]
 type Score = Double
 type Param = Double
 
-grid :: (MonadReader env m, MonadIO m, HasSettings env)
+grid :: (MonadReader env m, MonadBase IO m, HasSettings env)
      => Param -> Param -> Train -> [Tests] -> m (Maybe Model)
 grid _ _ _ []  = panic "Gargantext.Text.List.Learn.grid : empty test data"
 grid s e tr te = do
   let
-    grid' :: (MonadReader env m, MonadIO m, HasSettings env)
+    grid' :: (MonadReader env m, MonadBase IO m, HasSettings env)
           => Double -> Double
           -> Train
           -> [Tests]
           -> m (Score, Model)
     grid' x y tr' te' = do
-      model'' <- liftIO $ trainList x y tr'
+      model'' <- liftBase $ trainList x y tr'
       
       let
         model' = ModelSVM model'' (Just x) (Just y)
@@ -117,7 +117,7 @@ grid s e tr te = do
                              $ map (\(k,vs) -> zip (repeat k) vs)
                              $ Map.toList t
         
-          res' <- liftIO $ predictList m toGuess
+          res' <- liftBase $ predictList m toGuess
           pure $ score'' $ score' $ List.zip res res' 
       
       score <- mapM (getScore model') te'

src/Gargantext/Text/Terms/Multi/PosTagging.hs

@@ -48,8 +48,6 @@ import Gargantext.Prelude
 
 import Network.HTTP.Simple
 
-import Control.Monad.Catch      (MonadThrow)
-import Control.Monad.IO.Class  (MonadIO)
 import Data.String.Conversions (ConvertibleStrings)
 
 ------------------------------------------------------------------------
@@ -116,9 +114,10 @@ $(deriveJSON (unPrefix "_") ''PosSentences)
 -- 
 
 
-corenlp' :: ( MonadThrow m, MonadIO m, FromJSON a
+
+corenlp' :: ( FromJSON a
             , ConvertibleStrings p ByteString) =>
-            Lang -> p -> m (Response a)
+            Lang -> p -> IO (Response a)
 corenlp' lang txt = do
     let properties = case lang of
             EN -> "{\"annotators\": \"tokenize,ssplit,pos,ner\", \"outputFormat\": \"json\"}"

src/Gargantext/Viz/Graph.hs

@@ -10,6 +10,7 @@ Portability : POSIX
 -}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE DeriveGeneric     #-}
@@ -18,7 +19,6 @@ module Gargantext.Viz.Graph
   where
 
 import Control.Lens (makeLenses)
-import Control.Monad.IO.Class (MonadIO(liftIO))
 import Data.Aeson.TH (deriveJSON)
 import Data.ByteString.Lazy as DBL (readFile, writeFile)
 import Data.Swagger
@@ -189,7 +189,7 @@ graphV3ToGraphWithFiles g1 g2 = do
 
   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 
-readGraphFromJson :: MonadIO m => FilePath -> m (Maybe Graph)
+readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
 readGraphFromJson fp = do
-  graph <- liftIO $ DBL.readFile fp
+  graph <- liftBase $ DBL.readFile fp
   pure $ DA.decode graph

src/Gargantext/Viz/Graph/API.hs

@@ -28,7 +28,6 @@ module Gargantext.Viz.Graph.API
 import Debug.Trace (trace)
 import Control.Concurrent -- (forkIO)
 import Control.Lens (set, (^.), _Just, (^?))
-import Control.Monad.IO.Class (liftIO)
 import Data.Aeson
 import Data.Maybe (Maybe(..))
 import Data.Swagger
@@ -89,10 +88,10 @@ graphAPI u n =  getGraph  u n
 -- Each process has to be tailored
 getGraph' :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
 getGraph' u n = do
-  newGraph  <- liftIO newEmptyMVar
+  newGraph  <- liftBase newEmptyMVar
   g  <- getGraph u n
-  _  <- liftIO $ forkIO $ putMVar newGraph g
-  g' <- liftIO $ takeMVar newGraph
+  _  <- liftBase $ forkIO $ putMVar newGraph g
+  g' <- liftBase $ takeMVar newGraph
   pure g'
 -}
 getGraph :: UserId -> NodeId -> GargNoServer Graph
@@ -130,9 +129,9 @@ getGraph uId nId = do
     --                    _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
     --                    pure graph''
 
-  newGraph  <- liftIO newEmptyMVar
-  _  <- liftIO $ forkIO $ putMVar newGraph g
-  g' <- liftIO $ takeMVar newGraph
+  newGraph  <- liftBase newEmptyMVar
+  _  <- liftBase $ forkIO $ putMVar newGraph g
+  g' <- liftBase $ takeMVar newGraph
   pure {- $ trace (show g) $ -} g'
 
 
@@ -177,9 +176,9 @@ computeGraphAsync :: HasNodeError err
              -> NgramsRepo
              -> Cmd err Graph
 computeGraphAsync cId nt repo = do
-  g <- liftIO newEmptyMVar
+  g <- liftBase newEmptyMVar
   _ <- forkIO <$> putMVar g <$> computeGraph cId nt repo
-  g' <- liftIO $ takeMVar g
+  g' <- liftBase $ takeMVar g
   pure g'
 
 
@@ -228,7 +227,7 @@ type GraphAsyncAPI = Summary "Update graph"
 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 graphAsync u n =
   serveJobsAPI $
-    JobFunction (\_ log' -> graphAsync' u n (liftIO . log'))
+    JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
 
 
 graphAsync' :: UserId

src/Gargantext/Viz/Phylo/API.hs

@@ -42,7 +42,6 @@ import Servant
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 import Web.HttpApiData (parseUrlPiece, readTextData)
-import Control.Monad.IO.Class (liftIO)
 import Network.HTTP.Media ((//), (/:))
 
 ------------------------------------------------------------------------
@@ -108,7 +107,7 @@ getPhylo phId _lId l msb  = do
     branc = maybe 2 identity msb
     maybePhylo = hyperdataPhylo_data $ _node_hyperdata phNode
 
-  p <- liftIO $ viewPhylo2Svg $ viewPhylo level branc  $ maybe phyloFromQuery identity maybePhylo
+  p <- liftBase $ viewPhylo2Svg $ viewPhylo level branc  $ maybe phyloFromQuery identity maybePhylo
   pure (SVG p)
 ------------------------------------------------------------------------
 type PostPhylo =  QueryParam "listId" ListId

src/Gargantext/Viz/Phylo/Main.hs

@@ -72,7 +72,7 @@ flowPhylo cId = do
 
     docs = map ( (\(y,t) -> Document y t) . filterTerms patterns) docs'
 
-  --liftIO $ flowPhylo' (List.sortOn date docs) termList l m fp
+  --liftBase $ flowPhylo' (List.sortOn date docs) termList l m fp
   pure $ buildPhylo (List.sortOn date docs) termList
 
 

stack.yaml

@@ -47,7 +47,7 @@ extra-deps:
   #- git: https://github.com/delanoe/servant-job.git
   #commit: 7a7b7100e6d132adb4c11b25b2128e6309690ac0
 - git: https://github.com/np/servant-job.git
-  commit: 4016c76398a56e1a352a45b3ee9d698dd0dd2597
+  commit: 5bf03696edad27285b0588aba92b34b48db16832
 - git: https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
   commit: 7d74f96dfea8e51fbab1793cc0429b2fe741f73d
 - git: https://github.com/np/patches-map