Move a lot of code around into new modules
This commit is contained in:
John Wiegley
parent
35b0cc1c59
commit
9f6c2ba948
51
Nix.hs
Normal file
51
Nix.hs
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
module Nix where
|
||||
|
||||
import Control.Monad.Trans.Reader
|
||||
import qualified Data.Map.Lazy as Map
|
||||
import Nix.Builtins
|
||||
import Nix.Eval
|
||||
import Nix.Expr (NExpr)
|
||||
import Nix.Lint
|
||||
import Nix.Monad.Instance
|
||||
import Nix.Scope
|
||||
import Nix.Utils
|
||||
|
||||
-- | Evaluate a nix expression in the default context
|
||||
evalTopLevelExpr :: MonadNix m => Maybe FilePath -> NExpr -> m (NValueNF m)
|
||||
evalTopLevelExpr mdir expr = do
|
||||
base <- do
|
||||
base <- baseEnv
|
||||
case mdir of
|
||||
Nothing -> return base
|
||||
Just dir -> do
|
||||
ref <- buildThunk $ return $ NVLiteralPath dir
|
||||
let m = Map.singleton "__cwd" ref
|
||||
traceM $ "Setting __cwd = " ++ show dir
|
||||
return $ extendScope m base
|
||||
normalForm =<< pushScopes base (evalExpr expr)
|
||||
|
||||
evalTopLevelExprIO :: Maybe FilePath -> NExpr -> IO (NValueNF (Cyclic IO))
|
||||
evalTopLevelExprIO mdir expr =
|
||||
runReaderT (runCyclic (evalTopLevelExpr mdir expr)) emptyScopes
|
||||
|
||||
tracingEvalTopLevelExprIO :: Maybe FilePath -> NExpr
|
||||
-> IO (NValueNF (Cyclic IO))
|
||||
tracingEvalTopLevelExprIO mdir expr = do
|
||||
base <- case mdir of
|
||||
Nothing -> run baseEnv emptyScopes
|
||||
Just dir -> do
|
||||
ref <- run (buildThunk $ return $ NVLiteralPath dir) emptyScopes
|
||||
let m = Map.singleton "__cwd" ref
|
||||
traceM $ "Setting __cwd = " ++ show dir
|
||||
base <- run baseEnv emptyScopes
|
||||
return $ extendScope m base
|
||||
expr' <- tracingExprEval expr
|
||||
thnk <- run expr' base
|
||||
run (normalForm thnk) base
|
||||
where
|
||||
run = runReaderT . runCyclic
|
||||
|
||||
lintExpr :: NExpr -> IO ()
|
||||
lintExpr expr = run (checkExpr expr) =<< run baseEnv emptyScopes
|
||||
where
|
||||
run = runReaderT . runCyclic
|
||||
149
Nix/Builtins.hs
149
Nix/Builtins.hs
|
|
@ -1,22 +1,10 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
||||
|
||||
module Nix.Builtins
|
||||
(baseEnv, builtins, Cyclic(..), NestedScopes(..),
|
||||
evalTopLevelExpr, evalTopLevelExprIO,
|
||||
tracingEvalTopLevelExprIO)
|
||||
where
|
||||
module Nix.Builtins (baseEnv) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Align (alignWith)
|
||||
import Data.Char (isDigit)
|
||||
import Data.Fix
|
||||
import Data.IORef
|
||||
import qualified Data.Map.Lazy as Map
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
|
|
@ -24,50 +12,9 @@ import Data.These (fromThese)
|
|||
import Data.Foldable (foldlM)
|
||||
import Data.Traversable (mapM)
|
||||
import Nix.Atoms
|
||||
import Nix.Monad
|
||||
import Nix.Eval
|
||||
import Nix.Scope
|
||||
import Nix.Expr (NExpr)
|
||||
import Nix.Parser
|
||||
import Nix.Utils
|
||||
import System.Environment
|
||||
import System.Exit (ExitCode (ExitSuccess))
|
||||
import System.FilePath
|
||||
import System.Process (readProcessWithExitCode)
|
||||
|
||||
-- | Evaluate a nix expression in the default context
|
||||
evalTopLevelExpr :: MonadNix m => Maybe FilePath -> NExpr -> m (NValueNF m)
|
||||
evalTopLevelExpr mdir expr = do
|
||||
base <- do
|
||||
base <- baseEnv
|
||||
case mdir of
|
||||
Nothing -> return base
|
||||
Just dir -> do
|
||||
ref <- buildThunk $ return $ NVLiteralPath dir
|
||||
let m = Map.singleton "__cwd" ref
|
||||
traceM $ "Setting __cwd = " ++ show dir
|
||||
return $ extendScope m base
|
||||
normalForm =<< pushScopes base (evalExpr expr)
|
||||
|
||||
evalTopLevelExprIO :: Maybe FilePath -> NExpr -> IO (NValueNF (Cyclic IO))
|
||||
evalTopLevelExprIO mdir expr =
|
||||
runReaderT (runCyclic (evalTopLevelExpr mdir expr)) emptyScopes
|
||||
|
||||
tracingEvalTopLevelExprIO :: Maybe FilePath -> NExpr
|
||||
-> IO (NValueNF (Cyclic IO))
|
||||
tracingEvalTopLevelExprIO mdir expr = do
|
||||
base <- case mdir of
|
||||
Nothing -> run baseEnv emptyScopes
|
||||
Just dir -> do
|
||||
ref <- run (buildThunk $ return $ NVLiteralPath dir) emptyScopes
|
||||
let m = Map.singleton "__cwd" ref
|
||||
traceM $ "Setting __cwd = " ++ show dir
|
||||
base <- run baseEnv emptyScopes
|
||||
return $ extendScope m base
|
||||
expr' <- tracingExprEval expr
|
||||
thnk <- run expr' base
|
||||
run (normalForm thnk) base
|
||||
where
|
||||
run = runReaderT . runCyclic
|
||||
|
||||
baseEnv :: MonadNix m => m (NestedScopes (NThunk m))
|
||||
baseEnv = do
|
||||
|
|
@ -77,98 +24,6 @@ baseEnv = do
|
|||
where
|
||||
topLevelBuiltins = map mapping . filter isTopLevel <$> builtinsList
|
||||
|
||||
newtype Cyclic m a = Cyclic
|
||||
{ runCyclic :: ReaderT (NestedScopes (NThunk (Cyclic m))) m a }
|
||||
deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
|
||||
|
||||
data Deferred m
|
||||
= DeferredAction (m (NValue m))
|
||||
-- ^ This is closure over the environment where it was created.
|
||||
| ComputedValue (NValue m)
|
||||
|
||||
instance MonadNix (Cyclic IO) where
|
||||
-- jww (2018-03-29): We should use actually stacked scopes here, rather
|
||||
-- than constantly merging maps. The number of scope levels will usually
|
||||
-- be manageable, but the number of attributes within scopes can be
|
||||
-- enormous, making this one of the worst implementations.
|
||||
pushScopes s k = Cyclic $ local (combineScopes s) $ do
|
||||
scope <- runCyclic currentScope
|
||||
traceM $ "scope: " ++ show (() <$ scope)
|
||||
runCyclic k
|
||||
|
||||
clearScopes = Cyclic . local (const (NestedScopes [])) . runCyclic
|
||||
currentScope = Cyclic ask
|
||||
|
||||
-- If a variable is being asked for, it's needed in head normal form.
|
||||
lookupVar k = Cyclic $ do
|
||||
scope <- ask
|
||||
case scopeLookup k scope of
|
||||
Nothing -> return Nothing
|
||||
Just v -> runCyclic $ Just <$> forceThunk v
|
||||
|
||||
-- jww (2018-03-29): Cache which files have been read in.
|
||||
importFile = forceThunk >=> \case
|
||||
NVLiteralPath path -> do
|
||||
mres <- lookupVar "__cwd"
|
||||
path' <- case mres of
|
||||
Nothing -> do
|
||||
traceM "No known current directory"
|
||||
return path
|
||||
Just dir -> normalForm dir >>= \case
|
||||
Fix (NVLiteralPath dir') -> do
|
||||
traceM $ "Current directory for import is: "
|
||||
++ show dir'
|
||||
return $ dir' </> path
|
||||
x -> error $ "How can the current directory be: " ++ show x
|
||||
traceM $ "Importing file " ++ path'
|
||||
eres <- Cyclic $ parseNixFile path'
|
||||
case eres of
|
||||
Failure err -> error $ "Parse failed: " ++ show err
|
||||
Success expr -> do
|
||||
ref <- buildThunk $ return $
|
||||
NVLiteralPath $ takeDirectory path'
|
||||
-- Use this cookie so that when we evaluate the next
|
||||
-- import, we'll remember which directory its containing
|
||||
-- file was in.
|
||||
pushScope (newScope (Map.singleton "__cwd" ref))
|
||||
(evalExpr expr)
|
||||
p -> error $ "Unexpected argument to import: " ++ show (() <$ p)
|
||||
|
||||
addPath path = liftIO $ do
|
||||
(exitCode, out, _) <-
|
||||
readProcessWithExitCode "nix-store" ["--add", path] ""
|
||||
case exitCode of
|
||||
ExitSuccess -> return $ StorePath out
|
||||
_ -> error $ "No such file or directory: " ++ show path
|
||||
|
||||
getEnvVar = forceThunk >=> \case
|
||||
NVStr s _ -> do
|
||||
mres <- liftIO $ lookupEnv (Text.unpack s)
|
||||
return $ case mres of
|
||||
Nothing -> NVStr "" mempty
|
||||
Just v -> NVStr (Text.pack v) mempty
|
||||
p -> error $ "Unexpected argument to getEnv: " ++ show (() <$ p)
|
||||
|
||||
data NThunk (Cyclic IO) = NThunkIO (IORef (Deferred (Cyclic IO)))
|
||||
|
||||
valueRef value =
|
||||
liftIO $ NThunkIO <$> newIORef (ComputedValue value)
|
||||
|
||||
buildThunk action =
|
||||
liftIO $ NThunkIO <$> newIORef (DeferredAction action)
|
||||
|
||||
forceThunk (NThunkIO ref) = do
|
||||
eres <- liftIO $ readIORef ref
|
||||
case eres of
|
||||
ComputedValue value -> return value
|
||||
DeferredAction action -> do
|
||||
scope <- currentScope
|
||||
traceM $ "Forcing thunk in scope: " ++ show scope
|
||||
value <- action
|
||||
traceM $ "Forcing thunk computed: " ++ show (() <$ value)
|
||||
liftIO $ writeIORef ref (ComputedValue value)
|
||||
return value
|
||||
|
||||
builtins :: MonadNix m => m (ValueSet m)
|
||||
builtins = Map.fromList . map mapping <$> builtinsList
|
||||
|
||||
|
|
|
|||
266
Nix/Eval.hs
266
Nix/Eval.hs
|
|
@ -1,5 +1,4 @@
|
|||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
|
|
@ -13,7 +12,6 @@ module Nix.Eval
|
|||
builtin, builtin2, builtin3, atomText, valueText, buildArgument) where
|
||||
|
||||
import Control.Monad hiding (mapM, sequence)
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Align.Key
|
||||
|
|
@ -22,188 +20,16 @@ import Data.Functor.Identity
|
|||
import Data.List (intercalate)
|
||||
import qualified Data.Map.Lazy as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Monoid (appEndo)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.These
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics
|
||||
import Nix.Atoms
|
||||
import Nix.Expr
|
||||
import Nix.Monad
|
||||
import Nix.Scope
|
||||
import Nix.StringOperations (runAntiquoted)
|
||||
import Nix.Utils
|
||||
|
||||
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation
|
||||
-- is completed.
|
||||
data NValueF m r
|
||||
= NVConstant NAtom
|
||||
-- | A string has a value and a context, which can be used to record what a
|
||||
-- string has been build from
|
||||
| NVStr Text (DList Text)
|
||||
| NVList [r]
|
||||
| NVSet (Map.Map Text r)
|
||||
| NVFunction (Params (m r)) (m r)
|
||||
-- ^ A function is a closed set of parameters representing the "call
|
||||
-- signature", used at application time to check the type of arguments
|
||||
-- passed to the function. Since it supports default values which may
|
||||
-- depend on other values within the final argument set, this
|
||||
-- dependency is represented as a set of pending evaluations. The
|
||||
-- arguments are finally normalized into a set which is passed to the
|
||||
-- function.
|
||||
--
|
||||
-- Note that 'm r' is being used here because effectively a function
|
||||
-- and its set of default arguments is "never fully evaluated". This
|
||||
-- enforces in the type that it must be re-evaluated for each call.
|
||||
| NVLiteralPath FilePath
|
||||
| NVEnvPath FilePath
|
||||
| NVBuiltin String (NThunk m -> m (NValue m))
|
||||
-- ^ A builtin function is itself already in normal form. Also, it may
|
||||
-- or may not choose to evaluate its argument in the production of a
|
||||
-- result.
|
||||
deriving (Generic, Typeable, Functor)
|
||||
|
||||
-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue m' is
|
||||
-- a value in head normal form, where only the "top layer" has been
|
||||
-- evaluated. An action of type 'm (NValue m)' is a pending evualation that
|
||||
-- has yet to be performed. An 'NThunk m' is either a pending evaluation, or
|
||||
-- a value in head normal form. A 'ValueSet' is a set of mappings from keys
|
||||
-- to thunks.
|
||||
|
||||
type NValueNF m = Fix (NValueF m) -- normal form
|
||||
type NValue m = NValueF m (NThunk m) -- head normal form
|
||||
type ValueSet m = Map.Map Text (NThunk m)
|
||||
|
||||
instance Show f => Show (NValueF m f) where
|
||||
showsPrec = flip go where
|
||||
go (NVConstant atom) = showsCon1 "NVConstant" atom
|
||||
go (NVStr text context) = showsCon2 "NVStr" text (appEndo context [])
|
||||
go (NVList list) = showsCon1 "NVList" list
|
||||
go (NVSet attrs) = showsCon1 "NVSet" attrs
|
||||
go (NVFunction r _) = showsCon1 "NVFunction" (() <$ r)
|
||||
go (NVLiteralPath p) = showsCon1 "NVLiteralPath" p
|
||||
go (NVEnvPath p) = showsCon1 "NVEnvPath" p
|
||||
go (NVBuiltin name _) = showsCon1 "NVBuiltin" name
|
||||
|
||||
showsCon1 :: Show a => String -> a -> Int -> String -> String
|
||||
showsCon1 con a d =
|
||||
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
|
||||
|
||||
showsCon2 :: (Show a, Show b)
|
||||
=> String -> a -> b -> Int -> String -> String
|
||||
showsCon2 con a b d =
|
||||
showParen (d > 10)
|
||||
$ showString (con ++ " ")
|
||||
. showsPrec 11 a
|
||||
. showString " "
|
||||
. showsPrec 11 b
|
||||
|
||||
valueText :: forall m. MonadNix m => NValueNF m -> m (Text, DList Text)
|
||||
valueText = cata phi where
|
||||
phi :: NValueF m (m (Text, DList Text)) -> m (Text, DList Text)
|
||||
phi (NVConstant a) = pure (atomText a, mempty)
|
||||
phi (NVStr t c) = pure (t, c)
|
||||
phi (NVList _) = error "Cannot coerce a list to a string"
|
||||
phi (NVSet set)
|
||||
| Just asString <-
|
||||
-- TODO: Should this be run through valueText recursively?
|
||||
Map.lookup "__asString" set = asString
|
||||
| otherwise = error "Cannot coerce a set to a string"
|
||||
phi (NVFunction _ _) = error "Cannot coerce a function to a string"
|
||||
phi (NVLiteralPath originalPath) = do
|
||||
-- TODO: Capture and use the path of the file being processed as the
|
||||
-- base path
|
||||
storePath <- addPath originalPath
|
||||
pure (Text.pack $ unStorePath storePath, mempty)
|
||||
phi (NVEnvPath p) =
|
||||
-- TODO: Ensure this is a store path
|
||||
pure (Text.pack p, mempty)
|
||||
phi (NVBuiltin _ _) = error "Cannot coerce a function to a string"
|
||||
|
||||
valueTextNoContext :: MonadNix m => NValueNF m -> m Text
|
||||
valueTextNoContext = fmap fst . valueText
|
||||
|
||||
builtin :: MonadNix m => String -> (NThunk m -> m (NValue m)) -> m (NValue m)
|
||||
builtin name f = return $ NVBuiltin name f
|
||||
|
||||
builtin2 :: MonadNix m
|
||||
=> String -> (NThunk m -> NThunk m -> m (NValue m)) -> m (NValue m)
|
||||
builtin2 name f = builtin name (builtin name . f)
|
||||
|
||||
builtin3 :: MonadNix m
|
||||
=> String -> (NThunk m -> NThunk m -> NThunk m -> m (NValue m))
|
||||
-> m (NValue m)
|
||||
builtin3 name f =
|
||||
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
|
||||
|
||||
-- | A path into the nix store
|
||||
newtype StorePath = StorePath { unStorePath :: FilePath }
|
||||
|
||||
class MonadFix m => MonadNix m where
|
||||
currentScope :: m (NestedScopes (NThunk m))
|
||||
clearScopes :: m r -> m r
|
||||
pushScopes :: NestedScopes (NThunk m) -> m r -> m r
|
||||
lookupVar :: Text -> m (Maybe (NValue m))
|
||||
|
||||
pushScope :: Scope (NThunk m) -> m r -> m r
|
||||
pushScope = pushScopes . NestedScopes . (:[])
|
||||
|
||||
data NThunk m :: *
|
||||
|
||||
valueRef :: NValue m -> m (NThunk m)
|
||||
buildThunk :: m (NValue m) -> m (NThunk m)
|
||||
forceThunk :: NThunk m -> m (NValue m)
|
||||
|
||||
-- | Import a path into the nix store, and return the resulting path
|
||||
addPath :: FilePath -> m StorePath
|
||||
|
||||
importFile :: NThunk m -> m (NValue m)
|
||||
getEnvVar :: NThunk m -> m (NValue m)
|
||||
|
||||
deferInScope :: MonadNix m
|
||||
=> NestedScopes (NThunk m) -> m (NValue m) -> m (NThunk m)
|
||||
deferInScope scope = buildThunk . clearScopes . pushScopes scope
|
||||
|
||||
buildArgument :: forall m. MonadNix m
|
||||
=> Params (m (NThunk m)) -> NThunk m -> m (ValueSet m)
|
||||
buildArgument params arg = case params of
|
||||
Param name -> return $ Map.singleton name arg
|
||||
ParamSet ps m -> go ps m
|
||||
where
|
||||
go ps m = forceThunk arg >>= \case
|
||||
NVSet args -> do
|
||||
let (s, isVariadic) = case ps of
|
||||
FixedParamSet s' -> (s', False)
|
||||
VariadicParamSet s' -> (s', True)
|
||||
res <- loebM (alignWithKey (assemble isVariadic) args s)
|
||||
maybe (pure res) (selfInject res) m
|
||||
|
||||
x -> error $ "Expected set in function call, received: "
|
||||
++ show (() <$ x)
|
||||
|
||||
selfInject :: ValueSet m -> Text -> m (ValueSet m)
|
||||
selfInject res n = do
|
||||
ref <- valueRef $ NVSet res
|
||||
return $ Map.insert n ref res
|
||||
|
||||
assemble :: Bool
|
||||
-> Text
|
||||
-> These (NThunk m) (Maybe (m (NThunk m)))
|
||||
-> ValueSet m
|
||||
-> m (NThunk m)
|
||||
assemble isVariadic k = \case
|
||||
That Nothing -> error $ "Missing value for parameter: " ++ show k
|
||||
That (Just f) -> \args -> do
|
||||
scope <- currentScope
|
||||
traceM $ "Deferring default argument in scope: " ++ show scope
|
||||
buildThunk $ clearScopes $ do
|
||||
traceM $ "Evaluating default argument with args: "
|
||||
++ show (newScope args)
|
||||
pushScopes (extendScope args scope) (forceThunk =<< f)
|
||||
This x | isVariadic -> const (pure x)
|
||||
| otherwise -> error $ "Unexpected parameter: " ++ show k
|
||||
These x _ -> const (pure x)
|
||||
|
||||
-- | Evaluate an nix expression, with a given ValueSet as environment
|
||||
evalExpr :: MonadNix m => NExpr -> m (NValue m)
|
||||
evalExpr = cata eval
|
||||
|
|
@ -386,34 +212,45 @@ valueEq l r = case (l, r) of
|
|||
go _ _ = pure False
|
||||
_ -> pure False
|
||||
|
||||
tracingExprEval :: MonadNix m => NExpr -> IO (m (NValue m))
|
||||
tracingExprEval =
|
||||
flip runReaderT (0 :: Int)
|
||||
. fmap (runIdentity . snd)
|
||||
. adiM @() (pure <$> eval) psi
|
||||
buildArgument :: forall m. MonadNix m
|
||||
=> Params (m (NThunk m)) -> NThunk m -> m (ValueSet m)
|
||||
buildArgument params arg = case params of
|
||||
Param name -> return $ Map.singleton name arg
|
||||
ParamSet ps m -> go ps m
|
||||
where
|
||||
psi k v@(Fix x) = do
|
||||
depth <- ask
|
||||
liftIO $ putStrLn $ "eval: " ++ replicate (depth * 2) ' ' ++ show x
|
||||
res <- local succ $ k v
|
||||
liftIO $ putStrLn $ "eval: " ++ replicate (depth * 2) ' ' ++ "."
|
||||
return res
|
||||
go ps m = forceThunk arg >>= \case
|
||||
NVSet args -> do
|
||||
let (s, isVariadic) = case ps of
|
||||
FixedParamSet s' -> (s', False)
|
||||
VariadicParamSet s' -> (s', True)
|
||||
res <- loebM (alignWithKey (assemble isVariadic) args s)
|
||||
maybe (pure res) (selfInject res) m
|
||||
|
||||
exprNormalForm :: MonadNix m => NExpr -> m (NValueNF m)
|
||||
exprNormalForm = normalForm <=< evalExpr
|
||||
x -> error $ "Expected set in function call, received: "
|
||||
++ show (() <$ x)
|
||||
|
||||
normalForm :: MonadNix m => NValue m -> m (NValueNF m)
|
||||
normalForm = \case
|
||||
NVConstant a -> return $ Fix $ NVConstant a
|
||||
NVStr t s -> return $ Fix $ NVStr t s
|
||||
NVList l -> Fix . NVList <$> traverse (normalForm <=< forceThunk) l
|
||||
NVSet s -> Fix . NVSet <$> traverse (normalForm <=< forceThunk) s
|
||||
NVFunction p f -> do
|
||||
p' <- traverse (fmap (normalForm <=< forceThunk)) p
|
||||
return $ Fix $ NVFunction p' (normalForm =<< forceThunk =<< f)
|
||||
NVLiteralPath fp -> return $ Fix $ NVLiteralPath fp
|
||||
NVEnvPath p -> return $ Fix $ NVEnvPath p
|
||||
NVBuiltin name f -> return $ Fix $ NVBuiltin name f
|
||||
selfInject :: ValueSet m -> Text -> m (ValueSet m)
|
||||
selfInject res n = do
|
||||
ref <- valueRef $ NVSet res
|
||||
return $ Map.insert n ref res
|
||||
|
||||
assemble :: Bool
|
||||
-> Text
|
||||
-> These (NThunk m) (Maybe (m (NThunk m)))
|
||||
-> ValueSet m
|
||||
-> m (NThunk m)
|
||||
assemble isVariadic k = \case
|
||||
That Nothing -> error $ "Missing value for parameter: " ++ show k
|
||||
That (Just f) -> \args -> do
|
||||
scope <- currentScope
|
||||
traceM $ "Deferring default argument in scope: " ++ show scope
|
||||
buildThunk $ clearScopes $ do
|
||||
traceM $ "Evaluating default argument with args: "
|
||||
++ show (newScope args)
|
||||
pushScopes (extendScope args scope) (forceThunk =<< f)
|
||||
This x | isVariadic -> const (pure x)
|
||||
| otherwise -> error $ "Unexpected parameter: " ++ show k
|
||||
These x _ -> const (pure x)
|
||||
|
||||
attrSetAlter :: MonadNix m
|
||||
=> [Text]
|
||||
|
|
@ -499,3 +336,32 @@ evalKeyName dyn (DynamicKey k)
|
|||
v <- runAntiquoted evalString id k
|
||||
valueTextNoContext =<< normalForm v
|
||||
| otherwise = error "dynamic attribute not allowed in this context"
|
||||
|
||||
tracingExprEval :: MonadNix m => NExpr -> IO (m (NValue m))
|
||||
tracingExprEval =
|
||||
flip runReaderT (0 :: Int)
|
||||
. fmap (runIdentity . snd)
|
||||
. adiM @() (pure <$> eval) psi
|
||||
where
|
||||
psi k v@(Fix x) = do
|
||||
depth <- ask
|
||||
liftIO $ putStrLn $ "eval: " ++ replicate (depth * 2) ' ' ++ show x
|
||||
res <- local succ $ k v
|
||||
liftIO $ putStrLn $ "eval: " ++ replicate (depth * 2) ' ' ++ "."
|
||||
return res
|
||||
|
||||
exprNormalForm :: MonadNix m => NExpr -> m (NValueNF m)
|
||||
exprNormalForm = normalForm <=< evalExpr
|
||||
|
||||
normalForm :: MonadNix m => NValue m -> m (NValueNF m)
|
||||
normalForm = \case
|
||||
NVConstant a -> return $ Fix $ NVConstant a
|
||||
NVStr t s -> return $ Fix $ NVStr t s
|
||||
NVList l -> Fix . NVList <$> traverse (normalForm <=< forceThunk) l
|
||||
NVSet s -> Fix . NVSet <$> traverse (normalForm <=< forceThunk) s
|
||||
NVFunction p f -> do
|
||||
p' <- traverse (fmap (normalForm <=< forceThunk)) p
|
||||
return $ Fix $ NVFunction p' (normalForm =<< forceThunk =<< f)
|
||||
NVLiteralPath fp -> return $ Fix $ NVLiteralPath fp
|
||||
NVEnvPath p -> return $ Fix $ NVEnvPath p
|
||||
NVBuiltin name f -> return $ Fix $ NVBuiltin name f
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Nix.Lint (checkExpr, lintExpr) where
|
||||
module Nix.Lint (checkExpr) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Reader
|
||||
|
|
@ -10,6 +10,7 @@ import Nix.Atoms
|
|||
import Nix.Builtins
|
||||
import Nix.Eval
|
||||
import Nix.Expr
|
||||
import Nix.Monad
|
||||
import Nix.Scope
|
||||
|
||||
nullVal :: MonadNix m => m (NValue m)
|
||||
|
|
@ -56,8 +57,3 @@ check (NAbs a b) = do
|
|||
-- In order to check some of the other operations properly, we'd need static
|
||||
-- typing
|
||||
check _ = return ()
|
||||
|
||||
lintExpr :: NExpr -> IO ()
|
||||
lintExpr expr = run (checkExpr expr) =<< run baseEnv emptyScopes
|
||||
where
|
||||
run = runReaderT . runCyclic
|
||||
|
|
|
|||
147
Nix/Monad.hs
Normal file
147
Nix/Monad.hs
Normal file
|
|
@ -0,0 +1,147 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Nix.Monad where
|
||||
|
||||
import Control.Monad.Fix
|
||||
import Data.Fix
|
||||
import qualified Data.Map.Lazy as Map
|
||||
import Data.Monoid (appEndo)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics
|
||||
import Nix.Atoms
|
||||
import Nix.Expr.Types
|
||||
import Nix.Scope
|
||||
import Nix.Utils
|
||||
|
||||
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation
|
||||
-- is completed.
|
||||
data NValueF m r
|
||||
= NVConstant NAtom
|
||||
-- | A string has a value and a context, which can be used to record what a
|
||||
-- string has been build from
|
||||
| NVStr Text (DList Text)
|
||||
| NVList [r]
|
||||
| NVSet (Map.Map Text r)
|
||||
| NVFunction (Params (m r)) (m r)
|
||||
-- ^ A function is a closed set of parameters representing the "call
|
||||
-- signature", used at application time to check the type of arguments
|
||||
-- passed to the function. Since it supports default values which may
|
||||
-- depend on other values within the final argument set, this
|
||||
-- dependency is represented as a set of pending evaluations. The
|
||||
-- arguments are finally normalized into a set which is passed to the
|
||||
-- function.
|
||||
--
|
||||
-- Note that 'm r' is being used here because effectively a function
|
||||
-- and its set of default arguments is "never fully evaluated". This
|
||||
-- enforces in the type that it must be re-evaluated for each call.
|
||||
| NVLiteralPath FilePath
|
||||
| NVEnvPath FilePath
|
||||
| NVBuiltin String (NThunk m -> m (NValue m))
|
||||
-- ^ A builtin function is itself already in normal form. Also, it may
|
||||
-- or may not choose to evaluate its argument in the production of a
|
||||
-- result.
|
||||
deriving (Generic, Typeable, Functor)
|
||||
|
||||
-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue m' is
|
||||
-- a value in head normal form, where only the "top layer" has been
|
||||
-- evaluated. An action of type 'm (NValue m)' is a pending evualation that
|
||||
-- has yet to be performed. An 'NThunk m' is either a pending evaluation, or
|
||||
-- a value in head normal form. A 'ValueSet' is a set of mappings from keys
|
||||
-- to thunks.
|
||||
|
||||
type NValueNF m = Fix (NValueF m) -- normal form
|
||||
type NValue m = NValueF m (NThunk m) -- head normal form
|
||||
type ValueSet m = Map.Map Text (NThunk m)
|
||||
|
||||
instance Show f => Show (NValueF m f) where
|
||||
showsPrec = flip go where
|
||||
go (NVConstant atom) = showsCon1 "NVConstant" atom
|
||||
go (NVStr text context) = showsCon2 "NVStr" text (appEndo context [])
|
||||
go (NVList list) = showsCon1 "NVList" list
|
||||
go (NVSet attrs) = showsCon1 "NVSet" attrs
|
||||
go (NVFunction r _) = showsCon1 "NVFunction" (() <$ r)
|
||||
go (NVLiteralPath p) = showsCon1 "NVLiteralPath" p
|
||||
go (NVEnvPath p) = showsCon1 "NVEnvPath" p
|
||||
go (NVBuiltin name _) = showsCon1 "NVBuiltin" name
|
||||
|
||||
showsCon1 :: Show a => String -> a -> Int -> String -> String
|
||||
showsCon1 con a d =
|
||||
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
|
||||
|
||||
showsCon2 :: (Show a, Show b)
|
||||
=> String -> a -> b -> Int -> String -> String
|
||||
showsCon2 con a b d =
|
||||
showParen (d > 10)
|
||||
$ showString (con ++ " ")
|
||||
. showsPrec 11 a
|
||||
. showString " "
|
||||
. showsPrec 11 b
|
||||
|
||||
valueText :: forall m. MonadNix m => NValueNF m -> m (Text, DList Text)
|
||||
valueText = cata phi where
|
||||
phi :: NValueF m (m (Text, DList Text)) -> m (Text, DList Text)
|
||||
phi (NVConstant a) = pure (atomText a, mempty)
|
||||
phi (NVStr t c) = pure (t, c)
|
||||
phi (NVList _) = error "Cannot coerce a list to a string"
|
||||
phi (NVSet set)
|
||||
| Just asString <-
|
||||
-- TODO: Should this be run through valueText recursively?
|
||||
Map.lookup "__asString" set = asString
|
||||
| otherwise = error "Cannot coerce a set to a string"
|
||||
phi (NVFunction _ _) = error "Cannot coerce a function to a string"
|
||||
phi (NVLiteralPath originalPath) = do
|
||||
-- TODO: Capture and use the path of the file being processed as the
|
||||
-- base path
|
||||
storePath <- addPath originalPath
|
||||
pure (Text.pack $ unStorePath storePath, mempty)
|
||||
phi (NVEnvPath p) =
|
||||
-- TODO: Ensure this is a store path
|
||||
pure (Text.pack p, mempty)
|
||||
phi (NVBuiltin _ _) = error "Cannot coerce a function to a string"
|
||||
|
||||
valueTextNoContext :: MonadNix m => NValueNF m -> m Text
|
||||
valueTextNoContext = fmap fst . valueText
|
||||
|
||||
builtin :: MonadNix m => String -> (NThunk m -> m (NValue m)) -> m (NValue m)
|
||||
builtin name f = return $ NVBuiltin name f
|
||||
|
||||
builtin2 :: MonadNix m
|
||||
=> String -> (NThunk m -> NThunk m -> m (NValue m)) -> m (NValue m)
|
||||
builtin2 name f = builtin name (builtin name . f)
|
||||
|
||||
builtin3 :: MonadNix m
|
||||
=> String -> (NThunk m -> NThunk m -> NThunk m -> m (NValue m))
|
||||
-> m (NValue m)
|
||||
builtin3 name f =
|
||||
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
|
||||
|
||||
-- | A path into the nix store
|
||||
newtype StorePath = StorePath { unStorePath :: FilePath }
|
||||
|
||||
class MonadFix m => MonadNix m where
|
||||
currentScope :: m (NestedScopes (NThunk m))
|
||||
clearScopes :: m r -> m r
|
||||
pushScopes :: NestedScopes (NThunk m) -> m r -> m r
|
||||
lookupVar :: Text -> m (Maybe (NValue m))
|
||||
|
||||
pushScope :: Scope (NThunk m) -> m r -> m r
|
||||
pushScope = pushScopes . NestedScopes . (:[])
|
||||
|
||||
data NThunk m :: *
|
||||
|
||||
valueRef :: NValue m -> m (NThunk m)
|
||||
buildThunk :: m (NValue m) -> m (NThunk m)
|
||||
forceThunk :: NThunk m -> m (NValue m)
|
||||
|
||||
-- | Import a path into the nix store, and return the resulting path
|
||||
addPath :: FilePath -> m StorePath
|
||||
|
||||
importFile :: NThunk m -> m (NValue m)
|
||||
getEnvVar :: NThunk m -> m (NValue m)
|
||||
|
||||
deferInScope :: MonadNix m
|
||||
=> NestedScopes (NThunk m) -> m (NValue m) -> m (NThunk m)
|
||||
deferInScope scope = buildThunk . clearScopes . pushScopes scope
|
||||
115
Nix/Monad/Instance.hs
Normal file
115
Nix/Monad/Instance.hs
Normal file
|
|
@ -0,0 +1,115 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
||||
|
||||
module Nix.Monad.Instance where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Fix
|
||||
import Data.IORef
|
||||
import qualified Data.Map.Lazy as Map
|
||||
import qualified Data.Text as Text
|
||||
import Nix.Eval
|
||||
import Nix.Scope
|
||||
import Nix.Parser
|
||||
import Nix.Utils
|
||||
import System.Environment
|
||||
import System.Exit (ExitCode (ExitSuccess))
|
||||
import System.FilePath
|
||||
import System.Process (readProcessWithExitCode)
|
||||
|
||||
newtype Cyclic m a = Cyclic
|
||||
{ runCyclic :: ReaderT (NestedScopes (NThunk (Cyclic m))) m a }
|
||||
deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
|
||||
|
||||
data Deferred m
|
||||
= DeferredAction (m (NValue m))
|
||||
-- ^ This is closure over the environment where it was created.
|
||||
| ComputedValue (NValue m)
|
||||
|
||||
instance MonadNix (Cyclic IO) where
|
||||
-- jww (2018-03-29): We should use actually stacked scopes here, rather
|
||||
-- than constantly merging maps. The number of scope levels will usually
|
||||
-- be manageable, but the number of attributes within scopes can be
|
||||
-- enormous, making this one of the worst implementations.
|
||||
pushScopes s k = Cyclic $ local (combineScopes s) $ do
|
||||
scope <- runCyclic currentScope
|
||||
traceM $ "scope: " ++ show (() <$ scope)
|
||||
runCyclic k
|
||||
|
||||
clearScopes = Cyclic . local (const (NestedScopes [])) . runCyclic
|
||||
currentScope = Cyclic ask
|
||||
|
||||
-- If a variable is being asked for, it's needed in head normal form.
|
||||
lookupVar k = Cyclic $ do
|
||||
scope <- ask
|
||||
case scopeLookup k scope of
|
||||
Nothing -> return Nothing
|
||||
Just v -> runCyclic $ Just <$> forceThunk v
|
||||
|
||||
-- jww (2018-03-29): Cache which files have been read in.
|
||||
importFile = forceThunk >=> \case
|
||||
NVLiteralPath path -> do
|
||||
mres <- lookupVar "__cwd"
|
||||
path' <- case mres of
|
||||
Nothing -> do
|
||||
traceM "No known current directory"
|
||||
return path
|
||||
Just dir -> normalForm dir >>= \case
|
||||
Fix (NVLiteralPath dir') -> do
|
||||
traceM $ "Current directory for import is: "
|
||||
++ show dir'
|
||||
return $ dir' </> path
|
||||
x -> error $ "How can the current directory be: " ++ show x
|
||||
traceM $ "Importing file " ++ path'
|
||||
eres <- Cyclic $ parseNixFile path'
|
||||
case eres of
|
||||
Failure err -> error $ "Parse failed: " ++ show err
|
||||
Success expr -> do
|
||||
ref <- buildThunk $ return $
|
||||
NVLiteralPath $ takeDirectory path'
|
||||
-- Use this cookie so that when we evaluate the next
|
||||
-- import, we'll remember which directory its containing
|
||||
-- file was in.
|
||||
pushScope (newScope (Map.singleton "__cwd" ref))
|
||||
(evalExpr expr)
|
||||
p -> error $ "Unexpected argument to import: " ++ show (() <$ p)
|
||||
|
||||
addPath path = liftIO $ do
|
||||
(exitCode, out, _) <-
|
||||
readProcessWithExitCode "nix-store" ["--add", path] ""
|
||||
case exitCode of
|
||||
ExitSuccess -> return $ StorePath out
|
||||
_ -> error $ "No such file or directory: " ++ show path
|
||||
|
||||
getEnvVar = forceThunk >=> \case
|
||||
NVStr s _ -> do
|
||||
mres <- liftIO $ lookupEnv (Text.unpack s)
|
||||
return $ case mres of
|
||||
Nothing -> NVStr "" mempty
|
||||
Just v -> NVStr (Text.pack v) mempty
|
||||
p -> error $ "Unexpected argument to getEnv: " ++ show (() <$ p)
|
||||
|
||||
data NThunk (Cyclic IO) = NThunkIO (IORef (Deferred (Cyclic IO)))
|
||||
|
||||
valueRef value =
|
||||
liftIO $ NThunkIO <$> newIORef (ComputedValue value)
|
||||
|
||||
buildThunk action =
|
||||
liftIO $ NThunkIO <$> newIORef (DeferredAction action)
|
||||
|
||||
forceThunk (NThunkIO ref) = do
|
||||
eres <- liftIO $ readIORef ref
|
||||
case eres of
|
||||
ComputedValue value -> return value
|
||||
DeferredAction action -> do
|
||||
scope <- currentScope
|
||||
traceM $ "Forcing thunk in scope: " ++ show scope
|
||||
value <- action
|
||||
traceM $ "Forcing thunk computed: " ++ show (() <$ value)
|
||||
liftIO $ writeIORef ref (ComputedValue value)
|
||||
return value
|
||||
|
|
@ -6,7 +6,7 @@ module Nix.Utils (module Nix.Utils, module X) where
|
|||
import Control.Monad
|
||||
import Control.Monad.Fix
|
||||
import Data.Fix
|
||||
import Data.Monoid (appEndo, Endo)
|
||||
import Data.Monoid (Endo)
|
||||
|
||||
#define ENABLE_TRACING 1
|
||||
#if ENABLE_TRACING
|
||||
|
|
|
|||
|
|
@ -22,10 +22,13 @@ Flag Parsec
|
|||
Library
|
||||
Default-language: Haskell2010
|
||||
Exposed-modules:
|
||||
Nix
|
||||
Nix.Atoms
|
||||
Nix.Scope
|
||||
Nix.Eval
|
||||
Nix.Lint
|
||||
Nix.Monad
|
||||
Nix.Monad.Instance
|
||||
Nix.Builtins
|
||||
Nix.Parser
|
||||
Nix.Expr
|
||||
|
|
|
|||
|
|
@ -2,10 +2,12 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans #-}
|
||||
|
||||
module EvalTests (tests) where
|
||||
|
||||
import Data.String.Interpolate
|
||||
import Nix.Builtins
|
||||
import Nix
|
||||
import Nix.Eval
|
||||
import Nix.Expr
|
||||
import Nix.Parser
|
||||
|
|
|
|||
|
|
@ -13,9 +13,9 @@ import qualified Data.Map as Map
|
|||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as Text
|
||||
import GHC.Exts
|
||||
import Nix.Builtins
|
||||
import Nix
|
||||
import Nix.Eval
|
||||
import Nix.Lint
|
||||
import Nix.Monad.Instance
|
||||
import Nix.Parser
|
||||
import Nix.Pretty
|
||||
import System.Environment
|
||||
|
|
@ -39,7 +39,8 @@ From (git://nix)/tests/lang.sh we see that
|
|||
plain text output should be the same as the .exp,
|
||||
pass the extra flags to nix-instantiate
|
||||
|
||||
NIX_PATH=lang/dir3:lang/dir4 should be in the environment of all eval-okay-*.nix evaluations
|
||||
NIX_PATH=lang/dir3:lang/dir4 should be in the environment of all
|
||||
eval-okay-*.nix evaluations
|
||||
TEST_VAR=foo should be in all the environments # for eval-okay-getenv.nix
|
||||
-}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue