Skip to content

Commit 90f8e79

Browse files
layuslayus
committed
Thread hnix-store monad into the monad stack
1 parent d38db1c commit 90f8e79

File tree

4 files changed

+76
-50
lines changed

4 files changed

+76
-50
lines changed

‎hnix.cabal‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -402,8 +402,8 @@ library
402402
, gitrev >= 1.1.0 && < 1.4
403403
, hashable >= 1.2.5 && < 1.4
404404
, hashing >= 0.1.0 && < 0.2
405-
, hnix-store-core >= 0.2.0 && < 0.3
406-
, hnix-store-remote >= 0.2.0 && < 0.3
405+
, hnix-store-core >= 0.3.0 && < 0.4
406+
, hnix-store-remote >= 0.3.0 && < 0.4
407407
, http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.7
408408
, http-client-tls >= 0.3.5 && < 0.4
409409
, http-types >= 0.12.2 && < 0.13

‎src/Nix/Effects.hs‎

Lines changed: 21 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -242,47 +242,36 @@ type StorePathName = Text
242242
type FilePathFilter m = FilePath -> m Bool
243243
type StorePathSet = HS.HashSet StorePath
244244

245-
class Monad m => MonadStore m where
245+
class MonadIO m => MonadStore m where
246246

247247
-- | Add a path to the store, with bells and whistles
248-
addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
249-
default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
248+
addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m StorePath
249+
default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m StorePath
250250
addToStore a b c d = lift $ addToStore a b c d
251251

252-
-- | Add a nar (action) to the store
253-
-- addToStore' :: StorePathName -> IO Nar -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
252+
addTextToStore :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
253+
default addTextToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
254+
addTextToStore a b c d = lift $ addTextToStore a b c d
254255

255-
addTextToStore' :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
256-
default addTextToStore' :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
257-
addTextToStore' a b c d = lift $ addTextToStore' a b c d
258256

259-
parseStoreResult :: Monad m => String -> (Either String a, [Store.Logger]) -> m (Either ErrorCall a)
260-
parseStoreResult name res = case res of
261-
(Left msg, logs) -> return $ Left $ ErrorCall $ "Failed to execute '" ++ name ++ "': " ++ msg ++ "\n" ++ show logs
262-
(Right result, _) -> return $ Right result
257+
-- relying on show is not ideal, but way more concise.
258+
-- Bound to disappear anyway if we unify StorePath representation across hnix* projects
259+
convertStorePath :: Store.StorePath -> StorePath
260+
convertStorePath = StorePath . show
263261

264-
instance MonadStore IO where
262+
instance MonadIO m => MonadStore (Store.MonadStoreT m) where
265263

266-
addToStore name path recursive repair = case Store.makeStorePathName name of
267-
Left err -> return $ Left $ ErrorCall $ "String '" ++ show name ++ "' is not a valid path name: " ++ err
268-
Right pathName -> do
269-
-- TODO: redesign the filter parameter
270-
res <- Store.runStore $ Store.addToStore @'Store.SHA256 pathName path recursive (const False) repair
271-
parseStoreResult "addToStore" res >>= \case
272-
Left err -> return $ Left err
273-
Right storePath -> return $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath storePath
264+
addToStore name path recursive repair = do
265+
-- TODO: replace this error call by something smarter. throwE ? throwError ?
266+
pathName <- either error return $ Store.makeStorePathName name
267+
convertStorePath <$> Store.addToStore @'Store.SHA256 pathName path recursive (const False) repair
274268

275-
addTextToStore' name text references repair = do
276-
res <- Store.runStore $ Store.addTextToStore name text references repair
277-
parseStoreResult "addTextToStore" res >>= \case
278-
Left err -> return $ Left err
279-
Right path -> return $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath path
269+
addTextToStore name text references repair =
270+
convertStorePath <$> Store.addTextToStore name text references repair
280271

281-
addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
282-
addTextToStore a b c d = either throwError return =<< addTextToStore' a b c d
283272

284-
addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath
285-
addPath p = either throwError return =<< addToStore (T.pack $ takeFileName p) p True False
286-
287-
toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
273+
toFile_ :: MonadStore m => FilePath -> String -> m StorePath
288274
toFile_ p contents = addTextToStore (T.pack p) (T.pack contents) HS.empty False
275+
276+
addPath :: (MonadStore m) => FilePath -> m StorePath
277+
addPath p = addToStore (T.pack $ takeFileName p) p True False

‎src/Nix/Fresh.hs‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ import Control.Monad.Fail
2222
import Control.Monad.Reader
2323
import Control.Monad.Ref
2424
import Control.Monad.ST
25+
import Control.Monad.Trans.Control
2526
import Data.Typeable
2627

2728
import Nix.Var
@@ -50,6 +51,24 @@ instance MonadTrans (FreshIdT i) where
5051
instance MonadBase b m => MonadBase b (FreshIdT i m) where
5152
liftBase = FreshIdT . liftBase
5253

54+
-- | MonadBaseControl instance for FreshIdT
55+
--
56+
-- This one is needed for monad stacks containing hnix-store stores performing IO.
57+
--
58+
-- The reason why the MonadBaseControl instance is so convoluted is that I
59+
-- could not come up with a MonadTransControl instance. (layus, 2020-11)
60+
--
61+
-- ATM I have no idea if such an instance makes sense because the m is used
62+
-- inside the readable (Var m i) and MonadTransControl is supposed to be
63+
-- defined without mentioning that m
64+
--
65+
instance MonadBaseControl b m => MonadBaseControl b (FreshIdT i m) where
66+
type StM (FreshIdT i m) a = StM m a
67+
liftBaseWith f = FreshIdT $ ReaderT $ \r ->
68+
liftBaseWith $ \runInBase ->
69+
f $ runInBase . (\t -> runReaderT (unFreshIdT t) r)
70+
restoreM = (\action -> FreshIdT { unFreshIdT = ReaderT $ const action }) . restoreM
71+
5372
instance ( MonadVar m
5473
, Eq i
5574
, Ord i

‎src/Nix/Standard.hs‎

Lines changed: 34 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Control.Monad.Free
2929
import Control.Monad.Reader
3030
import Control.Monad.Ref
3131
import Control.Monad.State
32+
import Control.Monad.Trans.Control ( MonadBaseControl )
3233
import Data.HashMap.Lazy ( HashMap )
3334
import qualified Data.HashMap.Strict
3435
import Data.Text ( Text )
@@ -52,6 +53,8 @@ import Nix.Utils.Fix1
5253
import Nix.Value
5354
import Nix.Value.Monad
5455
import Nix.Var
56+
import System.Nix.Store.Remote ( runStore )
57+
import System.Nix.Store.Remote.Types ( MonadStoreT(..) )
5558

5659
-- All of the following type classes defer to the underlying 'm'.
5760

@@ -62,6 +65,7 @@ deriving instance MonadPaths (t (Fix1 t)) => MonadPaths (Fix1 t)
6265
deriving instance MonadInstantiate (t (Fix1 t)) => MonadInstantiate (Fix1 t)
6366
deriving instance MonadExec (t (Fix1 t)) => MonadExec (Fix1 t)
6467
deriving instance MonadIntrospect (t (Fix1 t)) => MonadIntrospect (Fix1 t)
68+
deriving instance MonadStore (t (Fix1 t)) => MonadStore (Fix1 t)
6569

6670
deriving instance MonadPutStr (t (Fix1T t m) m) => MonadPutStr (Fix1T t m)
6771
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)
7074
deriving instance MonadInstantiate (t (Fix1T t m) m) => MonadInstantiate (Fix1T t m)
7175
deriving instance MonadExec (t (Fix1T t m) m) => MonadExec (Fix1T t m)
7276
deriving instance MonadIntrospect (t (Fix1T t m) m) => MonadIntrospect (Fix1T t m)
77+
deriving instance MonadStore (t (Fix1T t m) m) => MonadStore (Fix1T t m)
7378

7479
type MonadFix1T t m = (MonadTrans (Fix1T t), Monad (t (Fix1T t m) m))
7580

@@ -84,10 +89,6 @@ instance (MonadFix1T t m, MonadAtomicRef m) => MonadAtomicRef (Fix1T t m) where
8489

8590
instance (MonadFix1T t m, MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m)
8691

87-
instance (MonadFix1T t m, MonadStore m) => MonadStore (Fix1T t m) where
88-
addToStore a b c d = lift $ addToStore a b c d
89-
addTextToStore' a b c d = lift $ addTextToStore' a b c d
90-
9192
{------------------------------------------------------------------------}
9293

9394
newtype StdCited m a = StdCited
@@ -192,9 +193,17 @@ instance ( MonadAtomicRef m
192193
-- whileForcingThunk frame =
193194
-- withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
194195

196+
-- MonadStoreT lacks some of these, needed in the deriving clause of StandardTF
197+
deriving instance MonadPlus m => MonadPlus (MonadStoreT m)
198+
deriving instance MonadFix m => MonadFix (MonadStoreT m)
199+
deriving instance MonadCatch m => MonadCatch (MonadStoreT m)
200+
deriving instance MonadThrow m => MonadThrow (MonadStoreT m)
201+
deriving instance MonadMask m => MonadMask (MonadStoreT m)
202+
195203
newtype StandardTF r m a
196204
= StandardTF (ReaderT (Context r (StdValue r))
197-
(StateT (HashMap FilePath NExprLoc, HashMap Text Text) m) a)
205+
(StateT (HashMap FilePath NExprLoc, HashMap Text Text)
206+
(MonadStoreT m)) a)
198207
deriving
199208
( Functor
200209
, Applicative
@@ -211,8 +220,12 @@ newtype StandardTF r m a
211220
, MonadState (HashMap FilePath NExprLoc, HashMap Text Text)
212221
)
213222

223+
instance (MonadIO m) => MonadStore (StandardTF r m) where
224+
addToStore a b d c = StandardTF $ lift $ lift $ addToStore a b c d
225+
addTextToStore a b c d = StandardTF $ lift $ lift $ addTextToStore a b c d
226+
214227
instance MonadTrans (StandardTF r) where
215-
lift = StandardTF . lift . lift
228+
lift = StandardTF . lift . lift . lift
216229

217230
instance (MonadPutStr r, MonadPutStr m) => MonadPutStr (StandardTF r m)
218231
instance (MonadHttp r, MonadHttp m) => MonadHttp (StandardTF r m)
@@ -222,6 +235,7 @@ instance (MonadInstantiate r, MonadInstantiate m) => MonadInstantiate (StandardT
222235
instance (MonadExec r, MonadExec m) => MonadExec (StandardTF r m)
223236
instance (MonadIntrospect r, MonadIntrospect m) => MonadIntrospect (StandardTF r m)
224237

238+
225239
{------------------------------------------------------------------------}
226240

227241
type StandardT m = Fix1T StandardTF m
@@ -233,25 +247,29 @@ instance MonadThunkId m => MonadThunkId (Fix1T StandardTF m) where
233247
type ThunkId (Fix1T StandardTF m) = ThunkId m
234248

235249
mkStandardT
236-
:: ReaderT
237-
(Context (StandardT m) (StdValue (StandardT m)))
238-
(StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m)
239-
a
250+
:: (ReaderT (Context (StandardT m) (StdValue (StandardT m)))
251+
(StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text)
252+
(MonadStoreT m)) a)
240253
-> StandardT m a
241254
mkStandardT = Fix1T . StandardTF
242255

243256
runStandardT
244257
:: StandardT m a
245-
-> ReaderT
246-
(Context (StandardT m) (StdValue (StandardT m)))
247-
(StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m)
248-
a
258+
-> (ReaderT (Context (StandardT m) (StdValue (StandardT m)))
259+
(StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text)
260+
(MonadStoreT m)) a)
249261
runStandardT (Fix1T (StandardTF m)) = m
250262

263+
runStoreSimple :: (MonadIO m, MonadBaseControl IO m) => MonadStoreT m a -> m a
264+
runStoreSimple action = do
265+
(res, _log) <- runStore action
266+
-- TODO: replace this error call by something smarter. throwE ? throwError ?
267+
either (error) return res
268+
251269
runWithBasicEffects
252-
:: (MonadIO m, MonadAtomicRef m) => Options -> StandardT (StdIdT m) a -> m a
270+
:: (MonadBaseControl IO m, MonadIO m, MonadAtomicRef m) => Options -> StandardT (StdIdT m) a -> m a
253271
runWithBasicEffects opts =
254-
go . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT
272+
go . runStoreSimple . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT
255273
where
256274
go action = do
257275
i <- newVar (1 :: Int)

0 commit comments

Comments
 (0)