Thread hnix-store monad into the monad stack

hnix.cabal

@@ -402,8 +402,8 @@ library
     , gitrev >= 1.1.0 && < 1.4
     , hashable >= 1.2.5 && < 1.4
     , hashing >= 0.1.0 && < 0.2
-    , hnix-store-core >= 0.2.0 && < 0.3
-    , hnix-store-remote >= 0.2.0 && < 0.3
+    , hnix-store-core >= 0.3.0 && < 0.4
+    , hnix-store-remote >= 0.3.0 && < 0.4
     , http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.7
     , http-client-tls >= 0.3.5 && < 0.4
     , http-types >= 0.12.2 && < 0.13

src/Nix/Effects.hs

@@ -242,47 +242,36 @@ type StorePathName = Text
 type FilePathFilter m = FilePath -> m Bool
 type StorePathSet = HS.HashSet StorePath
 
-class Monad m => MonadStore m where
+class MonadIO m => MonadStore m where
 
     -- | Add a path to the store, with bells and whistles
-    addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
-    default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
+    addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m StorePath
+    default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m StorePath
     addToStore a b c d = lift $ addToStore a b c d
 
-    -- | Add a nar (action) to the store
-    -- addToStore' :: StorePathName -> IO Nar -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
+    addTextToStore :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
+    default addTextToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
+    addTextToStore a b c d = lift $ addTextToStore a b c d
 
-    addTextToStore' :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
-    default addTextToStore' :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
-    addTextToStore' a b c d = lift $ addTextToStore' a b c d
 
-parseStoreResult :: Monad m => String -> (Either String a, [Store.Logger]) -> m (Either ErrorCall a)
-parseStoreResult name res = case res of
-  (Left msg, logs) -> return $ Left $ ErrorCall $ "Failed to execute '" ++ name ++ "': " ++ msg ++ "\n" ++ show logs
-  (Right result, _) -> return $ Right result
+-- relying on show is not ideal, but way more concise.
+-- Bound to disappear anyway if we unify StorePath representation across hnix* projects
+convertStorePath :: Store.StorePath -> StorePath
+convertStorePath = StorePath . show
 
-instance MonadStore IO where
+instance MonadIO m => MonadStore (Store.MonadStoreT m) where
 
-  addToStore name path recursive repair = case Store.makeStorePathName name of
-    Left err -> return $ Left $ ErrorCall $ "String '" ++ show name ++ "' is not a valid path name: " ++ err
-    Right pathName -> do
-      -- TODO: redesign the filter parameter
-      res <- Store.runStore $ Store.addToStore @'Store.SHA256 pathName path recursive (const False) repair
-      parseStoreResult "addToStore" res >>= \case
-        Left err -> return $ Left err
-        Right storePath -> return $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath storePath
+  addToStore name path recursive repair = do
+    -- TODO: replace this error call by something smarter. throwE ? throwError ?
+    pathName <- either error return $ Store.makeStorePathName name
+    convertStorePath <$> Store.addToStore @'Store.SHA256 pathName path recursive (const False) repair
 
-  addTextToStore' name text references repair = do
-    res <- Store.runStore $ Store.addTextToStore name text references repair
-    parseStoreResult "addTextToStore" res >>= \case
-      Left err -> return $ Left err
-      Right path -> return $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath path
+  addTextToStore name text references repair =
+    convertStorePath <$> Store.addTextToStore name text references repair
 
-addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
-addTextToStore a b c d = either throwError return =<< addTextToStore' a b c d
 
-addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath
-addPath p = either throwError return =<< addToStore (T.pack $ takeFileName p) p True False
-
-toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
+toFile_ :: MonadStore m => FilePath -> String -> m StorePath
 toFile_ p contents = addTextToStore (T.pack p) (T.pack contents) HS.empty False
+
+addPath :: (MonadStore m) => FilePath -> m StorePath
+addPath p = addToStore (T.pack $ takeFileName p) p True False

src/Nix/Fresh.hs

@@ -22,6 +22,7 @@ import           Control.Monad.Fail
 import           Control.Monad.Reader
 import           Control.Monad.Ref
 import           Control.Monad.ST
+import           Control.Monad.Trans.Control
 import           Data.Typeable
 
 import           Nix.Var
@@ -50,6 +51,24 @@ instance MonadTrans (FreshIdT i) where
 instance MonadBase b m => MonadBase b (FreshIdT i m) where
   liftBase = FreshIdT . liftBase
 
+-- | MonadBaseControl instance for FreshIdT
+--
+-- This one is needed for monad stacks containing hnix-store stores performing IO.
+--
+-- The reason why the MonadBaseControl instance is so convoluted is that I
+-- could not come up with a MonadTransControl instance. (layus, 2020-11)
+--
+-- ATM I have no idea if such an instance makes sense because the m is used
+-- inside the readable (Var m i) and MonadTransControl is supposed to be
+-- defined without mentioning that m
+--
+instance MonadBaseControl b m => MonadBaseControl b (FreshIdT i m) where
+  type StM (FreshIdT i m) a = StM m a
+  liftBaseWith   f = FreshIdT $ ReaderT $ \r ->
+                        liftBaseWith $ \runInBase ->
+                            f $ runInBase . (\t -> runReaderT (unFreshIdT t) r)
+  restoreM         = (\action -> FreshIdT { unFreshIdT = ReaderT $ const action }) . restoreM
+
 instance ( MonadVar m
          , Eq i
          , Ord i

src/Nix/Standard.hs

@@ -29,6 +29,7 @@ import           Control.Monad.Free
 import           Control.Monad.Reader
 import           Control.Monad.Ref
 import           Control.Monad.State
+import           Control.Monad.Trans.Control    ( MonadBaseControl )
 import           Data.HashMap.Lazy              ( HashMap )
 import qualified Data.HashMap.Strict
 import           Data.Text                      ( Text )
@@ -52,6 +53,8 @@ import           Nix.Utils.Fix1
 import           Nix.Value
 import           Nix.Value.Monad
 import           Nix.Var
+import           System.Nix.Store.Remote ( runStore )
+import           System.Nix.Store.Remote.Types ( MonadStoreT(..) )
 
 -- All of the following type classes defer to the underlying 'm'.
 
@@ -62,6 +65,7 @@ deriving instance MonadPaths (t (Fix1 t)) => MonadPaths (Fix1 t)
 deriving instance MonadInstantiate (t (Fix1 t)) => MonadInstantiate (Fix1 t)
 deriving instance MonadExec (t (Fix1 t)) => MonadExec (Fix1 t)
 deriving instance MonadIntrospect (t (Fix1 t)) => MonadIntrospect (Fix1 t)
+deriving instance MonadStore (t (Fix1 t)) => MonadStore (Fix1 t)
 
 deriving instance MonadPutStr (t (Fix1T t m) m) => MonadPutStr (Fix1T t m)
 deriving instance MonadHttp (t (Fix1T t m) m) => MonadHttp (Fix1T t m)
@@ -70,6 +74,7 @@ deriving instance MonadPaths (t (Fix1T t m) m) => MonadPaths (Fix1T t m)
 deriving instance MonadInstantiate (t (Fix1T t m) m) => MonadInstantiate (Fix1T t m)
 deriving instance MonadExec (t (Fix1T t m) m) => MonadExec (Fix1T t m)
 deriving instance MonadIntrospect (t (Fix1T t m) m) => MonadIntrospect (Fix1T t m)
+deriving instance MonadStore (t (Fix1T t m) m) => MonadStore (Fix1T t m)
 
 type MonadFix1T t m = (MonadTrans (Fix1T t), Monad (t (Fix1T t m) m))
 
@@ -84,10 +89,6 @@ instance (MonadFix1T t m, MonadAtomicRef m) => MonadAtomicRef (Fix1T t m) where
 
 instance (MonadFix1T t m, MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m)
 
-instance (MonadFix1T t m, MonadStore m) => MonadStore (Fix1T t m) where
-  addToStore a b c d = lift $ addToStore a b c d
-  addTextToStore' a b c d = lift $ addTextToStore' a b c d
-
 {------------------------------------------------------------------------}
 
 newtype StdCited m a = StdCited
@@ -192,9 +193,17 @@ instance ( MonadAtomicRef m
 -- whileForcingThunk frame =
 --   withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
 
+-- MonadStoreT lacks some of these, needed in the deriving clause of StandardTF
+deriving instance MonadPlus  m => MonadPlus  (MonadStoreT m)
+deriving instance MonadFix   m => MonadFix   (MonadStoreT m)
+deriving instance MonadCatch m => MonadCatch (MonadStoreT m)
+deriving instance MonadThrow m => MonadThrow (MonadStoreT m)
+deriving instance MonadMask  m => MonadMask  (MonadStoreT m)
+
 newtype StandardTF r m a
   = StandardTF (ReaderT (Context r (StdValue r))
-                        (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m) a)
+                        (StateT (HashMap FilePath NExprLoc, HashMap Text Text)
+                                (MonadStoreT m)) a)
   deriving
     ( Functor
     , Applicative
@@ -211,8 +220,12 @@ newtype StandardTF r m a
     , MonadState (HashMap FilePath NExprLoc, HashMap Text Text)
     )
 
+instance (MonadIO m) => MonadStore (StandardTF r m) where
+  addToStore a b d c = StandardTF $ lift $ lift $ addToStore a b c d
+  addTextToStore a b c d = StandardTF $ lift $ lift $ addTextToStore a b c d
+
 instance MonadTrans (StandardTF r) where
-  lift = StandardTF . lift . lift
+  lift = StandardTF . lift . lift . lift
 
 instance (MonadPutStr r, MonadPutStr m) => MonadPutStr (StandardTF r m)
 instance (MonadHttp r, MonadHttp m) => MonadHttp (StandardTF r m)
@@ -222,6 +235,7 @@ instance (MonadInstantiate r, MonadInstantiate m) => MonadInstantiate (StandardT
 instance (MonadExec r, MonadExec m) => MonadExec (StandardTF r m)
 instance (MonadIntrospect r, MonadIntrospect m) => MonadIntrospect (StandardTF r m)
 
+
 {------------------------------------------------------------------------}
 
 type StandardT m = Fix1T StandardTF m
@@ -233,25 +247,29 @@ instance MonadThunkId m => MonadThunkId (Fix1T StandardTF m) where
   type ThunkId (Fix1T StandardTF m) = ThunkId m
 
 mkStandardT
-  :: ReaderT
-       (Context (StandardT m) (StdValue (StandardT m)))
-       (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m)
-       a
+  :: (ReaderT (Context (StandardT m) (StdValue (StandardT m)))
+       (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text)
+         (MonadStoreT m)) a)
   -> StandardT m a
 mkStandardT = Fix1T . StandardTF
 
 runStandardT
   :: StandardT m a
-  -> ReaderT
-       (Context (StandardT m) (StdValue (StandardT m)))
-       (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m)
-       a
+  -> (ReaderT (Context (StandardT m) (StdValue (StandardT m)))
+       (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text)
+         (MonadStoreT m)) a)
 runStandardT (Fix1T (StandardTF m)) = m
 
+runStoreSimple :: (MonadIO m, MonadBaseControl IO m) => MonadStoreT m a -> m a
+runStoreSimple action = do
+    (res, _log) <- runStore action
+    -- TODO: replace this error call by something smarter. throwE ? throwError ?
+    either (error) return res
+
 runWithBasicEffects
-  :: (MonadIO m, MonadAtomicRef m) => Options -> StandardT (StdIdT m) a -> m a
+  :: (MonadBaseControl IO m, MonadIO m, MonadAtomicRef m) => Options -> StandardT (StdIdT m) a -> m a
 runWithBasicEffects opts =
-  go . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT
+  go . runStoreSimple . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT
  where
   go action = do
     i <- newVar (1 :: Int)