From 32850cd23e1ac0ad270df6c585b22e61e94e7aed Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Fri, 16 Nov 2018 18:10:50 -0500 Subject: [PATCH] Factor out instantiate and exec --- main/Repl.hs | 2 +- src/Nix/Effects.hs | 57 ++++++++++++++++++++++++++++++++++++++++++---- src/Nix/Exec.hs | 54 ++++++++++++------------------------------- 3 files changed, 67 insertions(+), 46 deletions(-) diff --git a/main/Repl.hs b/main/Repl.hs index 24206f7..a5ff215 100644 --- a/main/Repl.hs +++ b/main/Repl.hs @@ -21,7 +21,7 @@ module Repl where -import Nix +import Nix hiding (exec) import Nix.Convert import Nix.Eval import Nix.Scope diff --git a/src/Nix/Effects.hs b/src/Nix/Effects.hs index 97289b1..7e79a1a 100644 --- a/src/Nix/Effects.hs +++ b/src/Nix/Effects.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Nix.Effects where @@ -13,10 +15,12 @@ import qualified Data.Text as T import Network.HTTP.Client hiding (path) import Network.HTTP.Client.TLS import Network.HTTP.Types +import Nix.Expr import Nix.Frames +import Nix.Parser import Nix.Render -import Nix.Value import Nix.Utils +import Nix.Value import qualified System.Directory as S import System.Environment import System.Exit @@ -26,7 +30,7 @@ import System.Process -- | A path into the nix store newtype StorePath = StorePath { unStorePath :: FilePath } -class (MonadFile m, MonadStore m, MonadPutStr m, MonadHttp m, MonadEnv m) => MonadEffects m where +class (MonadFile m, MonadStore m, MonadPutStr m, MonadHttp m, MonadEnv m, MonadInstantiate m, MonadExec m) => MonadEffects m where -- | Determine the absolute path of relative path in the current context makeAbsolutePath :: FilePath -> m FilePath findEnvPath :: String -> m FilePath @@ -40,13 +44,56 @@ class (MonadFile m, MonadStore m, MonadPutStr m, MonadHttp m, MonadEnv m) => Mon derivationStrict :: NValue m -> m (NValue m) - nixInstantiateExpr :: String -> m (NValue m) - getRecursiveSize :: a -> m (NValue m) traceEffect :: String -> m () - exec :: [String] -> m (NValue m) +class Monad m => MonadExec m where + exec' :: [String] -> m (Either ErrorCall NExprLoc) + default exec' :: (MonadTrans t, MonadExec m', m ~ t m') => [String] -> m (Either ErrorCall NExprLoc) + exec' = lift . exec' + +instance MonadExec IO where + exec' = \case + [] -> return $ Left $ ErrorCall "exec: missing program" + (prog:args) -> do + (exitCode, out, _) <- + liftIO $ readProcessWithExitCode prog args "" + let t = T.strip (T.pack out) + let emsg = "program[" ++ prog ++ "] args=" ++ show args + case exitCode of + ExitSuccess -> + if T.null t + then return $ Left $ ErrorCall $ "exec has no output :" ++ emsg + else case parseNixTextLoc t of + Failure err -> + return $ Left $ ErrorCall $ + "Error parsing output of exec: " ++ show err ++ " " ++ emsg + Success v -> return $ Right v + err -> return $ Left $ ErrorCall $ + "exec failed: " ++ show err ++ " " ++ emsg + +class Monad m => MonadInstantiate m where + instantiateExpr :: String -> m (Either ErrorCall NExprLoc) + default instantiateExpr :: (MonadTrans t, MonadInstantiate m', m ~ t m') => String -> m (Either ErrorCall NExprLoc) + instantiateExpr = lift . instantiateExpr + +instance MonadInstantiate IO where + instantiateExpr expr = do + traceM $ "Executing: " + ++ show ["nix-instantiate", "--eval", "--expr ", expr] + (exitCode, out, err) <- + readProcessWithExitCode "nix-instantiate" + [ "--eval", "--expr", expr] "" + case exitCode of + ExitSuccess -> case parseNixTextLoc (T.pack out) of + Failure e -> + return $ Left $ ErrorCall $ + "Error parsing output of nix-instantiate: " ++ show e + Success v -> return $ Right v + status -> + return $ Left $ ErrorCall $ "nix-instantiate failed: " ++ show status + ++ ": " ++ err pathExists :: MonadFile m => FilePath -> m Bool pathExists = doesFileExist diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index 1cb01ce..d508e6e 100644 --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -40,6 +40,7 @@ import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.State.Strict (StateT(..)) import Data.Coerce import Data.Fix +import Data.GADT.Compare import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as M import Data.List @@ -70,9 +71,7 @@ import Nix.Value #ifdef MIN_VERSION_haskeline import System.Console.Haskeline.MonadException hiding (catch) #endif -import System.Exit (ExitCode (ExitSuccess)) import System.FilePath -import System.Process (readProcessWithExitCode) import Text.PrettyPrint.ANSI.Leijen (text) import qualified Text.PrettyPrint.ANSI.Leijen as P #ifdef MIN_VERSION_pretty_show @@ -504,8 +503,12 @@ instance MonadHttp m => MonadHttp (Lazy m) instance MonadEnv m => MonadEnv (Lazy m) +instance MonadInstantiate m => MonadInstantiate (Lazy m) + +instance MonadExec m => MonadExec (Lazy m) + instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m, - MonadPutStr m, MonadHttp m, MonadEnv m, + MonadPutStr m, MonadHttp m, MonadEnv m, MonadInstantiate m, MonadExec m, MonadIO m, Alternative m, MonadPlus m, Typeable m) => MonadEffects (Lazy m) where makeAbsolutePath origPath = do @@ -568,22 +571,6 @@ instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m, where coerceNix = toNix . Text.pack <=< coerceToString True True - nixInstantiateExpr expr = do - traceM $ "Executing: " - ++ show ["nix-instantiate", "--eval", "--expr ", expr] - (exitCode, out, err) <- - liftIO $ readProcessWithExitCode "nix-instantiate" - [ "--eval", "--expr", expr] "" - case exitCode of - ExitSuccess -> case parseNixTextLoc (Text.pack out) of - Failure err -> - throwError $ ErrorCall $ - "Error parsing output of nix-instantiate: " ++ show err - Success v -> evalExprLoc v - status -> - throwError $ ErrorCall $ "nix-instantiate failed: " ++ show status - ++ ": " ++ err - getRecursiveSize = #ifdef MIN_VERSION_ghc_datasize #if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804 @@ -597,25 +584,6 @@ instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m, traceEffect = putStrLn - exec = \case - [] -> throwError $ ErrorCall "exec: missing program" - (prog:args) -> do - (exitCode, out, _) <- - liftIO $ readProcessWithExitCode prog args "" - let t = Text.strip (Text.pack out) - let emsg = "program[" ++ prog ++ "] args=" ++ show args - case exitCode of - ExitSuccess -> - if Text.null t - then throwError $ ErrorCall $ "exec has no output :" ++ emsg - else case parseNixTextLoc t of - Failure err -> - throwError $ ErrorCall $ - "Error parsing output of exec: " ++ show err ++ " " ++ emsg - Success v -> evalExprLoc v - err -> throwError $ ErrorCall $ - "exec failed: " ++ show err ++ " " ++ emsg - runLazyM :: Options -> MonadIO m => Lazy m a -> m a runLazyM opts = (`evalStateT` M.empty) . (`runReaderT` newContext opts) @@ -716,7 +684,7 @@ findEnvPathM name = do exists <- doesFileExist path' return $ if exists then Just path' else Nothing -addTracing :: (MonadNix e m, Has e Options, MonadIO m, +addTracing :: (MonadNix e m, Has e Options, MonadReader Int n, Alternative n) => Alg NExprLocF (m a) -> Alg NExprLocF (n (m a)) addTracing k v = do @@ -741,7 +709,7 @@ addTracing k v = do print $ msg rendered <> text " ...done" return res -evalExprLoc :: forall e m. (MonadNix e m, Has e Options, MonadIO m) +evalExprLoc :: forall e m. (MonadNix e m, Has e Options) => NExprLoc -> m (NValue m) evalExprLoc expr = do opts :: Options <- asks (view hasLens) @@ -791,3 +759,9 @@ fetchTarball v = v >>= \case nixInstantiateExpr $ "builtins.fetchTarball { " ++ "url = \"" ++ Text.unpack url ++ "\"; " ++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }" + +exec :: (MonadExec m, Framed e m, MonadThrow m, Alternative m, MonadCatch m, MonadFix m, MonadEffects m, GEq (Ref m), MonadAtomicRef m, Typeable m, Has e (Scopes m (NThunk m)), Has e Options, Has e SrcSpan) => [String] -> m (NValue m) +exec args = either throwError evalExprLoc =<< exec' args + +nixInstantiateExpr :: (MonadInstantiate m, Framed e m, MonadThrow m, Alternative m, MonadCatch m, MonadFix m, MonadEffects m, GEq (Ref m), MonadAtomicRef m, Typeable m, Has e (Scopes m (NThunk m)), Has e Options, Has e SrcSpan) => String -> m (NValue m) +nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s