More fixes to lazy evaluation and scoping
This commit is contained in:
John Wiegley
parent
21b179b267
commit
4e698d76fa
110
Nix/Builtins.hs
110
Nix/Builtins.hs
|
|
@ -4,15 +4,18 @@
|
|||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
||||
|
||||
module Nix.Builtins
|
||||
(baseEnv, builtins, Cyclic(..), evalTopLevelExpr, evalTopLevelExprIO)
|
||||
(baseEnv, builtins, Cyclic(..), NestedMap(..),
|
||||
evalTopLevelExpr, evalTopLevelExprIO,
|
||||
tracingEvalTopLevelExprIO, lintExpr)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.State
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Fix
|
||||
import Data.IORef
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Map.Lazy as Map
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Traversable (mapM)
|
||||
|
|
@ -28,26 +31,41 @@ import System.Exit (ExitCode (ExitSuccess))
|
|||
evalTopLevelExpr :: MonadNix m => NExpr -> m (NValueNF m)
|
||||
evalTopLevelExpr expr = do
|
||||
base <- baseEnv
|
||||
normalForm =<< pushScope base (evalExpr expr)
|
||||
normalForm =<< pushScopes base (evalExpr expr)
|
||||
|
||||
evalTopLevelExprIO :: NExpr -> IO (NValueNF (Cyclic IO))
|
||||
evalTopLevelExprIO expr =
|
||||
evalStateT (runCyclic (evalTopLevelExpr expr)) Map.empty
|
||||
runReaderT (runCyclic (evalTopLevelExpr expr)) emptyMap
|
||||
|
||||
baseEnv :: MonadNix m => m (ValueSet m)
|
||||
tracingEvalTopLevelExprIO :: NExpr -> IO (NValueNF (Cyclic IO))
|
||||
tracingEvalTopLevelExprIO expr = do
|
||||
base <- run baseEnv emptyMap
|
||||
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 emptyMap
|
||||
where
|
||||
run = runReaderT . runCyclic
|
||||
|
||||
baseEnv :: MonadNix m => m (NestedMap (NThunk m))
|
||||
baseEnv = do
|
||||
ref <- valueRef . NVSet =<< builtins
|
||||
ref <- buildThunk . NVSet =<< builtins
|
||||
lst <- (("builtins", ref) :) <$> topLevelBuiltins
|
||||
return $ Map.fromList lst
|
||||
return . NestedMap . (:[]) $ Map.fromList lst
|
||||
where
|
||||
topLevelBuiltins = map mapping . filter isTopLevel <$> builtinsList
|
||||
|
||||
newtype Cyclic m a = Cyclic { runCyclic :: StateT (ValueSet (Cyclic m)) m a }
|
||||
newtype Cyclic m a = Cyclic
|
||||
{ runCyclic :: ReaderT (NestedMap (NThunk (Cyclic m))) m a }
|
||||
deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
|
||||
|
||||
data Deferred m
|
||||
= DeferredValue (m (NValue m))
|
||||
| DeferredThunk (m (NThunk m))
|
||||
= DeferredAction (NestedMap (NThunk m)) (m (NThunk m))
|
||||
-- ^ This is closure over the environment where it was created.
|
||||
| ComputedValue (NValue m)
|
||||
|
||||
instance MonadNix (Cyclic IO) where
|
||||
|
|
@ -55,19 +73,14 @@ instance MonadNix (Cyclic IO) where
|
|||
-- 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.
|
||||
pushScope s k = Cyclic $ do
|
||||
traceM $ "pushScope: s = " ++ show (() <$ s)
|
||||
res <- modify (s `Map.union`) >> runCyclic k
|
||||
traceM "pushScope done"
|
||||
return res
|
||||
pushScopes s k = Cyclic $ local (combineMaps s) $ do
|
||||
scope <- runCyclic currentScope
|
||||
traceM $ "scope: " ++ show (() <$ scope)
|
||||
runCyclic k
|
||||
|
||||
currentScope = Cyclic get
|
||||
|
||||
lookupVar k = Cyclic $ do
|
||||
s <- get
|
||||
case Map.lookup k s of
|
||||
Nothing -> return Nothing
|
||||
Just v -> return $ Just v
|
||||
clearScopes = Cyclic . local (const (NestedMap [])) . runCyclic
|
||||
currentScope = Cyclic ask
|
||||
lookupVar k = Cyclic $ nestedLookup k <$> ask
|
||||
|
||||
-- jww (2018-03-29): Cache which files have been read in.
|
||||
importFile path = forceThunk path >>= \case
|
||||
|
|
@ -80,45 +93,40 @@ instance MonadNix (Cyclic IO) where
|
|||
p -> error $ "Unexpected argument to import: " ++ show (() <$ p)
|
||||
|
||||
addPath path = liftIO $ do
|
||||
(exitCode, out, _) <- readProcessWithExitCode "nix-store" ["--add", path] ""
|
||||
(exitCode, out, _) <-
|
||||
readProcessWithExitCode "nix-store" ["--add", path] ""
|
||||
case exitCode of
|
||||
ExitSuccess -> return $ StorePath out
|
||||
_ -> error $ "No such file or directory: " ++ show path
|
||||
|
||||
data NThunk (Cyclic IO) =
|
||||
NThunkIO (Either (NValue (Cyclic IO)) (IORef (Deferred (Cyclic IO))))
|
||||
NThunkIO (Either (NValueNF (Cyclic IO))
|
||||
(IORef (Deferred (Cyclic IO))))
|
||||
|
||||
valueRef = return . NThunkIO . Left
|
||||
|
||||
buildThunk action = do
|
||||
traceM "Building a thunk"
|
||||
liftIO $ NThunkIO . Right <$> newIORef (DeferredValue action)
|
||||
buildThunk action =
|
||||
liftIO $ NThunkIO . Right <$> newIORef (ComputedValue action)
|
||||
|
||||
defer action = do
|
||||
traceM "Deferring an action"
|
||||
liftIO $ NThunkIO . Right <$> newIORef (DeferredThunk action)
|
||||
defer scope action = do
|
||||
traceM $ "Deferring action in scope: " ++ show (() <$ scope)
|
||||
liftIO $ NThunkIO . Right <$> newIORef (DeferredAction scope action)
|
||||
|
||||
forceThunk (NThunkIO (Left value)) =
|
||||
return $ NThunkIO . Left <$> unFix value
|
||||
|
||||
forceThunk (NThunkIO (Left value)) = return value
|
||||
forceThunk (NThunkIO (Right ref)) = do
|
||||
traceM "Forcing a thunk"
|
||||
eres <- liftIO $ readIORef ref
|
||||
case eres of
|
||||
ComputedValue value -> do
|
||||
traceM "Already forced, returning value"
|
||||
return value
|
||||
DeferredValue action -> do
|
||||
traceM "Executing action..."
|
||||
value <- action
|
||||
traceM "Executing action...done, storing..."
|
||||
ComputedValue value -> return value
|
||||
DeferredAction scope action -> do
|
||||
traceM $ "Forcing thunk in scope: " ++ show scope
|
||||
value <- Cyclic
|
||||
$ local (`combineMaps` scope)
|
||||
$ runCyclic
|
||||
$ forceThunk =<< action
|
||||
traceM $ "Forcing thunk computed: " ++ show (() <$ value)
|
||||
liftIO $ writeIORef ref (ComputedValue value)
|
||||
traceM "Executing action...done, storing...done"
|
||||
return value
|
||||
DeferredThunk action -> do
|
||||
traceM "Executing thunk..."
|
||||
value <- forceThunk =<< action
|
||||
traceM "Executing thunk...done, storing..."
|
||||
liftIO $ writeIORef ref (ComputedValue value)
|
||||
traceM "Executing thunk...done, storing...done"
|
||||
return value
|
||||
|
||||
builtins :: MonadNix m => m (ValueSet m)
|
||||
|
|
@ -149,7 +157,7 @@ builtinsList = sequence [
|
|||
-- Helpers
|
||||
|
||||
mkBool :: MonadNix m => Bool -> m (NThunk m)
|
||||
mkBool = valueRef . NVConstant . NBool
|
||||
mkBool = valueRef . Fix . NVConstant . NBool
|
||||
|
||||
extractBool :: MonadNix m => NThunk m -> m Bool
|
||||
extractBool arg = forceThunk arg >>= \case
|
||||
|
|
@ -165,7 +173,7 @@ evalPred f arg = forceThunk f >>= \case
|
|||
-- Primops
|
||||
|
||||
toString :: MonadNix m => NThunk m -> m (NThunk m)
|
||||
toString = valueRef . uncurry NVStr <=< valueText <=< normalForm
|
||||
toString = valueRef . uncurry ((Fix .) . NVStr) <=< valueText <=< normalForm
|
||||
|
||||
import_ :: MonadNix m => NThunk m -> m (NThunk m)
|
||||
import_ = importFile
|
||||
|
|
@ -173,7 +181,7 @@ import_ = importFile
|
|||
hasAttr :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
|
||||
hasAttr x y = (,) <$> forceThunk x <*> forceThunk y >>= \case
|
||||
(NVStr key _, NVSet aset) ->
|
||||
valueRef $ NVConstant . NBool $ Map.member key aset
|
||||
valueRef $ Fix . NVConstant . NBool $ Map.member key aset
|
||||
(x, y) -> error $ "Invalid types for builtin.hasAttr: "
|
||||
++ show (() <$ x, () <$ y)
|
||||
|
||||
|
|
|
|||
219
Nix/Eval.hs
219
Nix/Eval.hs
|
|
@ -8,12 +8,12 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Nix.Eval (NValue, NValueNF, NValueF(..), ValueSet, MonadNix(..),
|
||||
StorePath (..),
|
||||
evalExpr, tracingExprEval, checkExpr,
|
||||
exprNormalForm, normalForm,
|
||||
builtin, builtin2, atomText, valueText,
|
||||
buildArgument) where
|
||||
StorePath (..), NestedMap(..), nestedLookup, combineMaps,
|
||||
extendMap, emptyMap, evalExpr, tracingExprEval, checkExpr,
|
||||
exprNormalForm, normalForm, builtin, builtin2, atomText,
|
||||
valueText, buildArgument) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad hiding (mapM, sequence)
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.IO.Class
|
||||
|
|
@ -90,7 +90,7 @@ instance Show f => Show (NValueF m f) where
|
|||
type ValueSet m = Map.Map Text (NThunk m)
|
||||
|
||||
builtin :: MonadNix m => String -> (NThunk m -> m (NThunk m)) -> m (NThunk m)
|
||||
builtin name f = valueRef $ NVBuiltin name f
|
||||
builtin name f = valueRef $ Fix $ NVBuiltin name f
|
||||
|
||||
builtin2 :: MonadNix m
|
||||
=> String -> (NThunk m -> NThunk m -> m (NThunk m)) -> m (NThunk m)
|
||||
|
|
@ -125,38 +125,44 @@ atomText (NUri uri) = uri
|
|||
-- | A path into the nix store
|
||||
newtype StorePath = StorePath { unStorePath :: FilePath }
|
||||
|
||||
newtype NestedMap a = NestedMap { getNestedMap :: [Map.Map Text a] }
|
||||
deriving Functor
|
||||
|
||||
instance Show (NestedMap a) where
|
||||
show (NestedMap xs) = show $ map Map.keys xs
|
||||
|
||||
emptyMap :: NestedMap a
|
||||
emptyMap = NestedMap []
|
||||
|
||||
nestedLookup :: Text -> NestedMap a -> Maybe a
|
||||
nestedLookup key =
|
||||
foldr (\m rest -> Map.lookup key m <|> rest) Nothing . getNestedMap
|
||||
|
||||
combineMaps :: NestedMap a -> NestedMap a -> NestedMap a
|
||||
combineMaps (NestedMap xs) (NestedMap ys) = NestedMap (xs ++ ys)
|
||||
|
||||
extendMap :: Map.Map Text a -> NestedMap a -> NestedMap a
|
||||
extendMap x (NestedMap xs) = NestedMap (x:xs)
|
||||
|
||||
class MonadFix m => MonadNix m where
|
||||
currentScope :: m (NestedMap (NThunk m))
|
||||
clearScopes :: m r -> m r
|
||||
pushScopes :: NestedMap (NThunk m) -> m r -> m r
|
||||
lookupVar :: Text -> m (Maybe (NThunk m))
|
||||
|
||||
pushScope :: ValueSet m -> m r -> m r
|
||||
pushScope = pushScopes . NestedMap . (:[])
|
||||
|
||||
data NThunk m :: *
|
||||
currentScope :: m (ValueSet m)
|
||||
pushScope :: ValueSet m -> m r -> m r
|
||||
lookupVar :: Text -> m (Maybe (NThunk m))
|
||||
importFile :: NThunk m -> m (NThunk m)
|
||||
|
||||
valueRef :: NValueNF m -> m (NThunk m)
|
||||
buildThunk :: NValue m -> m (NThunk m)
|
||||
forceThunk :: NThunk m -> m (NValue m)
|
||||
defer :: NestedMap (NThunk m) -> m (NThunk m) -> m (NThunk m)
|
||||
|
||||
-- | Import a path into the nix store, and return the resulting path
|
||||
addPath :: FilePath -> m StorePath
|
||||
|
||||
buildThunk :: m (NValue m) -> m (NThunk m)
|
||||
defer :: m (NThunk m) -> m (NThunk m)
|
||||
forceThunk :: NThunk m -> m (NValue m)
|
||||
|
||||
valueRef :: NValue m -> m (NThunk m)
|
||||
valueRef = buildThunk . return
|
||||
|
||||
wrap :: forall m. MonadNix m => NValueNF m -> m (NThunk m)
|
||||
wrap = cata phi
|
||||
where
|
||||
phi :: NValueF m (m (NThunk m)) -> m (NThunk m)
|
||||
phi = \case
|
||||
NVConstant a -> valueRef $ NVConstant a
|
||||
NVStr t s -> valueRef $ NVStr t s
|
||||
NVList l -> valueRef . NVList =<< sequence l
|
||||
NVSet s -> valueRef . NVSet =<< sequence s
|
||||
NVFunction p f -> do
|
||||
p' <- sequence p
|
||||
valueRef . NVFunction p' =<< f
|
||||
NVLiteralPath fp -> valueRef $ NVLiteralPath fp
|
||||
NVEnvPath p -> valueRef $ NVEnvPath p
|
||||
NVBuiltin name f -> valueRef $ NVBuiltin name f
|
||||
importFile :: NThunk m -> m (NThunk m)
|
||||
|
||||
buildArgument :: forall m. MonadNix m
|
||||
=> Params (m (NThunk m)) -> NThunk m -> m (ValueSet m)
|
||||
|
|
@ -167,37 +173,36 @@ buildArgument params arg = case params of
|
|||
go ps m = forceThunk arg >>= \case
|
||||
NVSet args -> do
|
||||
let (s, isVariadic) = case ps of
|
||||
FixedParamSet s' -> (s', False)
|
||||
FixedParamSet s' -> (s', False)
|
||||
VariadicParamSet s' -> (s', True)
|
||||
env <- currentScope
|
||||
res <- loebM (alignWithKey (assemble env isVariadic) args s)
|
||||
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)
|
||||
ref <- buildThunk $ NVSet res
|
||||
return $ Map.insert n ref res
|
||||
|
||||
assemble :: ValueSet m
|
||||
-> Bool
|
||||
assemble :: Bool
|
||||
-> Text
|
||||
-> These (NThunk m) (Maybe (m (NThunk m)))
|
||||
-> Map.Map Text (NThunk m)
|
||||
-> m (NThunk m)
|
||||
assemble env isVariadic k = \case
|
||||
assemble isVariadic k = \case
|
||||
That Nothing -> error $ "Missing value for parameter: " ++ show k
|
||||
That (Just f) -> \args ->
|
||||
-- Make sure the "scope at definition" (currentScope) is present
|
||||
-- when we evaluate the default action, plus the argument scope
|
||||
-- (env).
|
||||
defer $ pushScope env $ pushScope args f
|
||||
This x ->
|
||||
if isVariadic
|
||||
then const (pure x)
|
||||
else error $ "Unexpected parameter: " ++ show k
|
||||
These x _ -> const (pure x)
|
||||
That (Just f) -> \args -> do
|
||||
scope <- currentScope
|
||||
traceM $ "Deferring default argument in scope: " ++ show scope
|
||||
defer scope $ do
|
||||
traceM $ "Evaluating default argument with args: "
|
||||
++ show (NestedMap [args])
|
||||
pushScope args 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 (NThunk m)
|
||||
|
|
@ -209,13 +214,13 @@ eval (NSym var) = do
|
|||
traceM $ "NSym..1: var = " ++ show var
|
||||
fromMaybe (error $ "Undefined variable: " ++ show var) <$> lookupVar var
|
||||
|
||||
eval (NConstant x) = valueRef $ NVConstant x
|
||||
eval (NConstant x) = valueRef $ Fix $ NVConstant x
|
||||
eval (NStr str) = evalString str
|
||||
eval (NLiteralPath p) = valueRef $ NVLiteralPath p
|
||||
eval (NEnvPath p) = valueRef $ NVEnvPath p
|
||||
eval (NLiteralPath p) = valueRef $ Fix $ NVLiteralPath p
|
||||
eval (NEnvPath p) = valueRef $ Fix $ NVEnvPath p
|
||||
|
||||
eval (NUnary op arg) = arg >>= forceThunk >>= \case
|
||||
NVConstant c -> valueRef $ NVConstant $ case (op, c) of
|
||||
NVConstant c -> valueRef $ Fix $ NVConstant $ case (op, c) of
|
||||
(NNeg, NInt i) -> NInt (-i)
|
||||
(NNot, NBool b) -> NBool (not b)
|
||||
_ -> error $ "unsupported argument type for unary operator "
|
||||
|
|
@ -230,7 +235,7 @@ eval (NBinary op larg rarg) = do
|
|||
++ show (() <$ lval, op, () <$ rval)
|
||||
case (lval, rval) of
|
||||
(NVConstant lc, NVConstant rc) ->
|
||||
valueRef $ NVConstant $ case (op, lc, rc) of
|
||||
valueRef $ Fix $ NVConstant $ case (op, lc, rc) of
|
||||
(NEq, l, r) -> NBool $ l == r
|
||||
(NNEq, l, r) -> NBool $ l /= r
|
||||
(NLt, l, r) -> NBool $ l < r
|
||||
|
|
@ -246,61 +251,67 @@ eval (NBinary op larg rarg) = do
|
|||
(NDiv, NInt l, NInt r) -> NInt $ l `div` r
|
||||
_ -> error unsupportedTypes
|
||||
(NVStr ls lc, NVStr rs rc) -> case op of
|
||||
NPlus -> valueRef $ NVStr (ls `mappend` rs) (lc `mappend` rc)
|
||||
NPlus -> valueRef $ Fix $ NVStr (ls `mappend` rs) (lc `mappend` rc)
|
||||
_ -> error unsupportedTypes
|
||||
(NVSet ls, NVSet rs) -> case op of
|
||||
NUpdate -> valueRef $ NVSet $ rs `Map.union` ls
|
||||
NUpdate -> buildThunk $ NVSet $ rs `Map.union` ls
|
||||
_ -> error unsupportedTypes
|
||||
(NVList ls, NVList rs) -> case op of
|
||||
NConcat -> valueRef $ NVList $ ls ++ rs
|
||||
NConcat -> buildThunk $ NVList $ ls ++ rs
|
||||
_ -> error unsupportedTypes
|
||||
(NVLiteralPath ls, NVLiteralPath rs) -> case op of
|
||||
NPlus -> valueRef $ NVLiteralPath $ ls ++ rs -- TODO: Canonicalise path
|
||||
NPlus -> valueRef $ Fix $ NVLiteralPath $ ls ++ rs -- TODO: Canonicalise path
|
||||
_ -> error unsupportedTypes
|
||||
(NVLiteralPath ls, NVStr rs rc) -> case op of
|
||||
-- TODO: Canonicalise path
|
||||
NPlus -> valueRef $ NVStr (Text.pack ls `mappend` rs) rc
|
||||
NPlus -> valueRef $ Fix $ NVStr (Text.pack ls `mappend` rs) rc
|
||||
_ -> error unsupportedTypes
|
||||
_ -> error unsupportedTypes
|
||||
|
||||
eval (NSelect aset attr alternative) = do
|
||||
aset' <- normalForm =<< aset
|
||||
ks <- evalSelector True attr
|
||||
case extract aset' ks of
|
||||
Just v -> do
|
||||
traceM $ "Wrapping a selector: " ++ show v
|
||||
wrap v
|
||||
aset' <- forceThunk =<< aset
|
||||
ks <- evalSelector True attr
|
||||
mres <- extract aset' ks
|
||||
case mres of
|
||||
Just v -> do
|
||||
traceM $ "Wrapping a selector: " ++ show (() <$ v)
|
||||
buildThunk v
|
||||
Nothing -> case alternative of
|
||||
Just v -> v
|
||||
Nothing -> error $ "could not look up attribute "
|
||||
++ intercalate "." (map Text.unpack ks)
|
||||
++ " in " ++ show aset'
|
||||
++ " in " ++ show (() <$ aset')
|
||||
where
|
||||
extract (Fix (NVSet s)) (k:ks) = case Map.lookup k s of
|
||||
Just v -> extract v ks
|
||||
Nothing -> Nothing
|
||||
extract _ (_:_) = Nothing
|
||||
extract v [] = Just v
|
||||
extract (NVSet s) (k:ks) = case Map.lookup k s of
|
||||
Just v -> do
|
||||
s' <- forceThunk v
|
||||
extract s' ks
|
||||
Nothing -> return Nothing
|
||||
extract _ (_:_) = return Nothing
|
||||
extract v [] = return $ Just v
|
||||
|
||||
eval (NHasAttr aset attr) = aset >>= forceThunk >>= \case
|
||||
NVSet s -> evalSelector True attr >>= \case
|
||||
[keyName] -> valueRef $ NVConstant $ NBool $ keyName `Map.member` s
|
||||
[keyName] ->
|
||||
valueRef $ Fix $ NVConstant $ NBool $ keyName `Map.member` s
|
||||
_ -> error "attr name argument to hasAttr is not a single-part name"
|
||||
_ -> error "argument to hasAttr has wrong type"
|
||||
|
||||
eval (NList l) = valueRef . NVList =<< sequence l
|
||||
eval (NList l) = do
|
||||
scope <- currentScope
|
||||
buildThunk . NVList =<< traverse (defer scope) l
|
||||
|
||||
eval (NSet binds) = do
|
||||
traceM "NSet..1"
|
||||
s <- evalBinds True False binds
|
||||
traceM $ "NSet..2: s = " ++ show (() <$ s)
|
||||
valueRef $ NVSet s
|
||||
buildThunk $ NVSet s
|
||||
|
||||
eval (NRecSet binds) = do
|
||||
traceM "NRecSet..1"
|
||||
s <- evalBinds True True binds
|
||||
traceM $ "NRecSet..2: s = " ++ show (() <$ s)
|
||||
valueRef $ NVSet s
|
||||
buildThunk $ NVSet s
|
||||
|
||||
eval (NLet binds e) = do
|
||||
traceM "Let..1"
|
||||
|
|
@ -316,7 +327,7 @@ eval (NIf cond t f) = cond >>= forceThunk >>= \case
|
|||
eval (NWith scope e) = scope >>= forceThunk >>= \case
|
||||
NVSet scope' -> do
|
||||
env <- currentScope
|
||||
pushScope scope' $ pushScope env e
|
||||
pushScopes (combineMaps env (NestedMap [scope'])) e
|
||||
_ -> error "scope must be a set in with statement"
|
||||
|
||||
eval (NAssert cond e) = cond >>= forceThunk >>= \case
|
||||
|
|
@ -327,14 +338,23 @@ eval (NAssert cond e) = cond >>= forceThunk >>= \case
|
|||
eval (NApp fun arg) = fun >>= forceThunk >>= \case
|
||||
NVFunction params f -> do
|
||||
args <- buildArgument params =<< arg
|
||||
pushScope args f
|
||||
traceM $ "Evaluating function application with args: "
|
||||
++ show (NestedMap [args])
|
||||
scope <- currentScope
|
||||
traceM $ "Building function result thunk in scope: "
|
||||
++ show scope
|
||||
buildThunk =<< clearScopes (pushScope args (forceThunk =<< f))
|
||||
NVBuiltin _ f -> f =<< arg
|
||||
_ -> error "Attempt to call non-function"
|
||||
|
||||
eval (NAbs a b) =
|
||||
eval (NAbs params body) = do
|
||||
-- It is the environment at the definition site, not the call site, that
|
||||
-- needs to be used when evaluation the body and the default arguments
|
||||
valueRef $ NVFunction a b
|
||||
-- needs to be used when evaluating the body and default arguments, hence
|
||||
-- we defer here so the present scope is restored when the parameters and
|
||||
-- body are forced during application.
|
||||
scope <- currentScope
|
||||
traceM $ "Creating lambda abstraction in scope: " ++ show scope
|
||||
buildThunk $ NVFunction (defer scope <$> params) (defer scope body)
|
||||
|
||||
tracingExprEval :: MonadNix m => NExpr -> IO (m (NThunk m))
|
||||
tracingExprEval =
|
||||
|
|
@ -372,10 +392,10 @@ attrSetAlter :: MonadNix m
|
|||
-> m (Map.Map Text (m (NThunk m)))
|
||||
attrSetAlter [] _ _ = error "invalid selector with no components"
|
||||
attrSetAlter (p:ps) m val = case Map.lookup p m of
|
||||
Nothing | null ps -> go
|
||||
| otherwise -> recurse Map.empty
|
||||
Just v | null ps -> go
|
||||
| otherwise -> v >>= forceThunk >>= \case
|
||||
Nothing | null ps -> trace ("alter..1") $ go
|
||||
| otherwise -> trace ("alter..2") $ recurse Map.empty
|
||||
Just v | null ps -> trace ("alter..3") $ go
|
||||
| otherwise -> trace ("alter..4") $ v >>= forceThunk >>= \case
|
||||
NVSet s -> recurse (fmap pure s)
|
||||
_ -> error $ "attribute " ++ attr ++ " is not a set"
|
||||
where
|
||||
|
|
@ -385,8 +405,11 @@ attrSetAlter (p:ps) m val = case Map.lookup p m of
|
|||
|
||||
recurse s = attrSetAlter ps s val >>= \m' ->
|
||||
if | Map.null m' -> return m
|
||||
| otherwise ->
|
||||
return $ Map.insert p (buildThunk $ NVSet <$> sequence m') m
|
||||
| otherwise -> do
|
||||
scope <- currentScope
|
||||
return $ Map.insert p (embed scope m') m
|
||||
where
|
||||
embed scope m' = buildThunk . NVSet =<< traverse (defer scope) m'
|
||||
|
||||
evalBinds :: forall m. MonadNix m
|
||||
=> Bool
|
||||
|
|
@ -403,19 +426,13 @@ evalBinds allowDynamic recursive = buildResult . concat <=< mapM go
|
|||
|
||||
buildResult :: [([Text], m (NThunk m))] -> m (ValueSet m)
|
||||
buildResult bindings = do
|
||||
traceM "buildResult..1"
|
||||
s <- foldM insert Map.empty bindings
|
||||
traceM "buildResult..2"
|
||||
scope <- currentScope
|
||||
if recursive
|
||||
then do
|
||||
env <- currentScope
|
||||
loebM (encapsulate env <$> s)
|
||||
else sequence s
|
||||
then loebM (encapsulate scope <$> s)
|
||||
else traverse (defer scope) s
|
||||
|
||||
encapsulate env f attrs =
|
||||
-- Make sure the "scope at definition" (env') is present when we
|
||||
-- evaluate the attr value, plus the enclosing attr scope (env).
|
||||
defer $ pushScope env $ pushScope attrs f
|
||||
encapsulate scope f attrs = defer scope $ pushScope attrs f
|
||||
|
||||
insert m (path, value) = attrSetAlter path m value
|
||||
|
||||
|
|
@ -423,7 +440,7 @@ evalString :: MonadNix m => NString (m (NThunk m)) -> m (NThunk m)
|
|||
evalString nstr = do
|
||||
let fromParts parts = do
|
||||
(t, c) <- mconcat <$> mapM go parts
|
||||
valueRef $ NVStr t c
|
||||
valueRef $ Fix $ NVStr t c
|
||||
case nstr of
|
||||
Indented parts -> fromParts parts
|
||||
DoubleQuoted parts -> fromParts parts
|
||||
|
|
@ -440,7 +457,7 @@ evalSelector dyn = mapM evalKeyName where
|
|||
| otherwise = error "dynamic attribute not allowed in this context"
|
||||
|
||||
nullVal :: MonadNix m => m (NThunk m)
|
||||
nullVal = valueRef (NVConstant NNull)
|
||||
nullVal = valueRef $ Fix $ NVConstant NNull
|
||||
|
||||
-- | Evaluate an nix expression, with a given ValueSet as environment
|
||||
checkExpr :: MonadNix m => NExpr -> m ()
|
||||
|
|
@ -461,6 +478,10 @@ check (NRecSet binds) =
|
|||
check (NLet binds e) =
|
||||
(`pushScope` e) =<< evalBinds True True (fmap (fmap (const nullVal)) binds)
|
||||
|
||||
-- check (NWith _scope e) = do
|
||||
-- env <- currentScope
|
||||
-- pushScope env e
|
||||
|
||||
check (NAbs a b) = do
|
||||
nv <- nullVal
|
||||
case a of
|
||||
|
|
|
|||
10
Nix/Utils.hs
10
Nix/Utils.hs
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Nix.Utils (module Nix.Utils, module X) where
|
||||
|
||||
|
|
@ -48,3 +49,12 @@ adiM :: (Monoid b, Applicative s, Traversable s, Traversable t, Monad m)
|
|||
adiM f g = g ((go <=< traverse (adiM f g)) . unFix)
|
||||
where
|
||||
go = traverse (traverse f . sequenceA) . sequenceA
|
||||
|
||||
adiT :: forall s t m a. (Traversable t, Monad m, Monad s)
|
||||
=> (t a -> m a)
|
||||
-> ((Fix t -> s (m a)) -> Fix t -> s (m a))
|
||||
-> Fix t -> s (m a)
|
||||
adiT f g = g (go . fmap (adiT f g) . unFix)
|
||||
where
|
||||
go :: t (s (m a)) -> s (m a)
|
||||
go = fmap ((f =<<) . sequenceA) . sequenceA
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ let
|
|||
, parsers, regex-tdfa, regex-tdfa-text, semigroups, split, stdenv
|
||||
, tasty, tasty-hunit, tasty-th, text, transformers, trifecta
|
||||
, unordered-containers, these, optparse-applicative, interpolate
|
||||
, process
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "hnix";
|
||||
|
|
@ -19,7 +20,7 @@ let
|
|||
libraryHaskellDepends = [
|
||||
ansi-wl-pprint base containers data-fix deepseq deriving-compat
|
||||
parsers regex-tdfa regex-tdfa-text semigroups text transformers
|
||||
trifecta unordered-containers these
|
||||
trifecta unordered-containers these process
|
||||
];
|
||||
executableHaskellDepends = [
|
||||
ansi-wl-pprint base containers data-fix deepseq optparse-applicative
|
||||
|
|
|
|||
30
main/Main.hs
30
main/Main.hs
|
|
@ -2,16 +2,13 @@
|
|||
|
||||
module Main where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.State
|
||||
import qualified Data.Map as Map
|
||||
import Nix.Builtins
|
||||
import Nix.Eval
|
||||
import Nix.Parser
|
||||
import Nix.Pretty
|
||||
import Options.Applicative hiding (ParserResult(..))
|
||||
import System.IO
|
||||
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
|
||||
import Control.Monad
|
||||
import Nix.Builtins
|
||||
import Nix.Parser
|
||||
import Nix.Pretty
|
||||
import Options.Applicative hiding (ParserResult(..))
|
||||
import System.IO
|
||||
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
|
||||
|
||||
data Options = Options
|
||||
{ verbose :: Bool
|
||||
|
|
@ -60,14 +57,9 @@ main = do
|
|||
case eres of
|
||||
Failure err -> hPutStrLn stderr $ "Parse failed: " ++ show err
|
||||
Success expr -> do
|
||||
base <- run baseEnv Map.empty
|
||||
when (check opts) $
|
||||
run (checkExpr expr) base
|
||||
if | evaluate opts, debug opts -> do
|
||||
expr' <- tracingExprEval expr
|
||||
thnk <- run expr' base
|
||||
val <- run (normalForm thnk) base
|
||||
print val
|
||||
when (check opts) $ lintExpr expr
|
||||
if | evaluate opts, debug opts ->
|
||||
print =<< tracingEvalTopLevelExprIO expr
|
||||
| evaluate opts ->
|
||||
putStrLn . printNix =<< evalTopLevelExprIO expr
|
||||
| debug opts ->
|
||||
|
|
@ -75,8 +67,6 @@ main = do
|
|||
| otherwise ->
|
||||
displayIO stdout $ renderPretty 0.4 80 (prettyNix expr)
|
||||
where
|
||||
run expr = evalStateT (runCyclic expr)
|
||||
|
||||
optsDef :: ParserInfo Options
|
||||
optsDef = info (helper <*> mainOptions)
|
||||
(fullDesc <> progDesc "" <> header "hnix")
|
||||
|
|
|
|||
|
|
@ -79,17 +79,9 @@ instance (Show r, Eq r) => Eq (NValueF m r) where
|
|||
|
||||
constantEqual :: NExpr -> NExpr -> Assertion
|
||||
constantEqual a b = do
|
||||
a' <- evaluate a
|
||||
b' <- evaluate b
|
||||
a' <- tracingEvalTopLevelExprIO a
|
||||
b' <- tracingEvalTopLevelExprIO b
|
||||
assertEqual "" a' b'
|
||||
where
|
||||
run expr = evalStateT (runCyclic expr)
|
||||
|
||||
evaluate expr = do
|
||||
base <- run baseEnv Map.empty
|
||||
expr' <- tracingExprEval expr
|
||||
thnk <- run expr' base
|
||||
run (normalForm thnk) base
|
||||
|
||||
constantEqualStr :: String -> String -> Assertion
|
||||
constantEqualStr a b =
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@ module NixLanguageTests (genTests) where
|
|||
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Exception
|
||||
import Control.Monad.Trans.State
|
||||
import Data.List (delete, sort)
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Map (Map)
|
||||
|
|
@ -68,26 +67,19 @@ genTests = do
|
|||
|
||||
assertParse :: FilePath -> Assertion
|
||||
assertParse file = parseNixFile file >>= \case
|
||||
Success expr -> do
|
||||
base <- run baseEnv Map.empty
|
||||
run (checkExpr expr) base
|
||||
Failure err -> assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err
|
||||
where
|
||||
run expr = evalStateT (runCyclic expr)
|
||||
Success expr -> lintExpr expr
|
||||
Failure err -> assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err
|
||||
|
||||
assertParseFail :: FilePath -> Assertion
|
||||
assertParseFail file = do
|
||||
eres <- parseNixFile file
|
||||
catch (case eres of
|
||||
Success expr -> do
|
||||
base <- run baseEnv Map.empty
|
||||
run (checkExpr expr) base
|
||||
lintExpr expr
|
||||
assertFailure $ "Unexpected success parsing `"
|
||||
++ file ++ ":\nParsed value: " ++ show expr
|
||||
Failure _ -> return ()) $ \(_ :: SomeException) ->
|
||||
return ()
|
||||
where
|
||||
run expr = evalStateT (runCyclic expr)
|
||||
|
||||
assertLangOk :: FilePath -> Assertion
|
||||
assertLangOk file = do
|
||||
|
|
|
|||
Loading…
Reference in a new issue