Skip to content

Commit

Permalink
Fresh{,.Basic}, Effects: m clean-up
Browse files Browse the repository at this point in the history
  • Loading branch information
Anton-Latukha committed Feb 8, 2021
1 parent 850f569 commit efcce65
Show file tree
Hide file tree
Showing 3 changed files with 33 additions and 29 deletions.
40 changes: 20 additions & 20 deletions src/Nix/Effects.hs
Original file line number Diff line number Diff line change
Expand Up @@ -44,7 +44,7 @@ import qualified System.Info
import System.Process

import qualified System.Nix.Hash as Store
import qualified System.Nix.Store.Remote as Store
import qualified System.Nix.Store.Remote as Store.Remote
import qualified System.Nix.StorePath as Store

-- | A path into the nix store
Expand Down Expand Up @@ -227,11 +227,11 @@ instance MonadHttp IO where


class Monad m => MonadPutStr m where
--TODO: Should this be used *only* when the Nix to be evaluated invokes a
--`trace` operation?
putStr :: String -> m ()
default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m ()
putStr = lift . putStr
--TODO: Should this be used *only* when the Nix to be evaluated invokes a
--`trace` operation?
putStr :: String -> m ()
default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m ()
putStr = lift . putStr

putStrLn :: MonadPutStr m => String -> m ()
putStrLn = putStr . (<> "\n")
Expand All @@ -251,20 +251,20 @@ type StorePathSet = HS.HashSet StorePath

class Monad m => MonadStore m where

-- | Copy the contents of a local path to the store. The resulting store
-- path is returned. Note: This does not support yet support the expected
-- `filter` function that allows excluding some files.
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 a b c d = lift $ addToStore a b c d
-- | Copy the contents of a local path to the store. The resulting store
-- path is returned. Note: This does not support yet support the expected
-- `filter` function that allows excluding some files.
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 a b c d = lift $ addToStore a b c d

-- | Like addToStore, but the contents written to the output path is a
-- regular file containing the given string.
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
-- | Like addToStore, but the contents written to the output path is a
-- regular file containing the given string.
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 :: Monad m => String -> (Either String a, [Store.Remote.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
Expand All @@ -275,13 +275,13 @@ instance MonadStore IO where
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
res <- Store.Remote.runStore $ Store.Remote.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

addTextToStore' name text references repair = do
res <- Store.runStore $ Store.addTextToStore name text references repair
res <- Store.Remote.runStore $ Store.Remote.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
Expand Down
19 changes: 11 additions & 8 deletions src/Nix/Fresh.hs
Original file line number Diff line number Diff line change
Expand Up @@ -50,14 +50,16 @@ instance MonadTrans (FreshIdT i) where
instance MonadBase b m => MonadBase b (FreshIdT i m) where
liftBase = FreshIdT . liftBase

instance ( MonadVar m
, Eq i
, Ord i
, Show i
, Enum i
, Typeable i
)
=> MonadThunkId (FreshIdT i m) where
instance
( MonadVar m
, Eq i
, Ord i
, Show i
, Enum i
, Typeable i
)
=> MonadThunkId (FreshIdT i m)
where
type ThunkId (FreshIdT i m) = i
freshId = FreshIdT $ do
v <- ask
Expand All @@ -69,6 +71,7 @@ runFreshIdT i m = runReaderT (unFreshIdT m) i
-- Orphan instance needed by Infer.hs and Lint.hs

-- Since there's no forking, it's automatically atomic.
-- NOTE: MonadAtomicRef (ST s) can be upstreamed to `ref-tf`
instance MonadAtomicRef (ST s) where
atomicModifyRef r f = do
v <- readRef r
Expand Down
3 changes: 2 additions & 1 deletion src/Nix/Fresh/Basic.hs
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ import Nix.Value

type StdIdT = FreshIdT Int

-- NOTE: These would be removed by: https://github.com/haskell-nix/hnix/pull/804
instance (MonadFail m, MonadFile m) => MonadFile (StdIdT m)
instance MonadIntrospect m => MonadIntrospect (StdIdT m)
instance MonadStore m => MonadStore (StdIdT m)
Expand All @@ -45,6 +46,6 @@ instance (MonadEffects t f m, MonadDataContext f m)
pathToDefaultNix = lift . pathToDefaultNix @t @f @m
derivationStrict v = do
i <- FreshIdT ask
p <- lift $ derivationStrict @t @f @m (unliftNValue (runFreshIdT i) v)
p <- lift $ derivationStrict @t @f @m $ unliftNValue (runFreshIdT i) v
return $ liftNValue (runFreshIdT i) p
traceEffect = lift . traceEffect @t @f @m

0 comments on commit efcce65

Please sign in to comment.