picnoir
/
hnix
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement laziness, although without support for concurrency

This commit is contained in:
John Wiegley 2018-03-29 15:35:12 -07:00
parent c82dec901f
commit 8f24c7b645
7 changed files with 222 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
Nix/Builtins.hs
View File

@ -8,10 +8,9 @@ module Nix.Builtins
where
import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.State
-- import Data.Fix
-- import Data.Functor.Identity
import Data.IORef
import qualified Data.Map as Map
import Data.Text (Text)
@ -21,24 +20,33 @@ import Nix.Atoms
import Nix.Eval
import Nix.Expr (NExpr)
import Nix.Parser
-- import System.IO.Unsafe
import Nix.Utils
-- | Evaluate a nix expression in the default context
evalTopLevelExpr :: MonadNix m => NExpr -> m (NValueNF m)
evalTopLevelExpr = normalForm <=< pushScope baseEnv . evalExpr
evalTopLevelExpr expr = do
base <- baseEnv
normalForm =<< pushScope base (evalExpr expr)
evalTopLevelExprIO :: NExpr -> IO (NValueNF (Cyclic IO))
evalTopLevelExprIO expr =
evalStateT (runCyclic (evalTopLevelExpr expr)) Map.empty
baseEnv :: MonadNix m => ValueSet m
baseEnv = Map.fromList
$ ("builtins", valueRef $ NVSet builtins) : topLevelBuiltins
baseEnv :: MonadNix m => m (ValueSet m)
baseEnv = do
ref <- valueRef . NVSet =<< builtins
lst <- (("builtins", ref) :) <$> topLevelBuiltins
return $ Map.fromList lst
where
topLevelBuiltins = map mapping (filter isTopLevel builtinsList)
topLevelBuiltins = map mapping . filter isTopLevel <$> builtinsList
newtype Cyclic m a = Cyclic { runCyclic :: StateT (ValueSet (Cyclic m)) m a }
deriving (Functor, Applicative, Monad, MonadIO)
deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
data Deferred m
= DeferredValue (m (NValue m))
| DeferredThunk (m (NThunk m))
| ComputedValue (NValue m)
instance MonadNix (Cyclic IO) where
-- jww (2018-03-29): We should use actually stacked scopes here, rather
@ -51,12 +59,12 @@ instance MonadNix (Cyclic IO) where
s <- get
case Map.lookup k s of
Nothing -> return Nothing
Just v -> Just <$> runCyclic v
Just v -> return $ Just v
-- jww (2018-03-29): Cache which files have been read in.
importFile path = forceThunk path >>= \case
NVLiteralPath path -> Cyclic $ do
liftIO $ putStrLn $ "Importing file " ++ path
traceM $ "Importing file " ++ path
eres <- parseNixFile path
case eres of
Failure err -> error $ "Parse failed: " ++ show err
@ -64,35 +72,55 @@ instance MonadNix (Cyclic IO) where
p -> error $ "Unexpected argument to import: " ++ show (() <$ p)
data NThunk (Cyclic IO) =
NThunkIO (IORef (Either (Cyclic IO (NValue (Cyclic IO)))
(NValue (Cyclic IO))))
NThunkIO (Either (NValue (Cyclic IO)) (IORef (Deferred (Cyclic IO))))
buildThunk action = liftIO $ NThunkIO <$> newIORef (Left action)
valueRef value = liftIO $ NThunkIO <$> newIORef (Right value)
valueRef = return . NThunkIO . Left
forceThunk (NThunkIO ref) = do
buildThunk action = do
traceM "Building a thunk"
liftIO $ NThunkIO . Right <$> newIORef (DeferredValue action)
defer action = do
traceM "Deferring an action"
liftIO $ NThunkIO . Right <$> newIORef (DeferredThunk action)
forceThunk (NThunkIO (Left value)) = return value
forceThunk (NThunkIO (Right ref)) = do
traceM "Forcing a thunk"
eres <- liftIO $ readIORef ref
case eres of
Right value -> return value
Left action -> do
ComputedValue value -> do
traceM "Already forced, returning value"
return value
DeferredValue action -> do
traceM "Executing action..."
value <- action
liftIO $ writeIORef ref (Right value)
traceM "Executing action...done, storing..."
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 => ValueSet m
builtins = Map.fromList $ map mapping builtinsList
builtins :: MonadNix m => m (ValueSet m)
builtins = Map.fromList . map mapping <$> builtinsList
data BuiltinType = Normal | TopLevel
data Builtin m = Builtin
{ kind :: BuiltinType
, mapping :: (Text, m (NThunk m))
, mapping :: (Text, NThunk m)
}
isTopLevel :: Builtin m -> Bool
isTopLevel b = case kind b of Normal -> False; TopLevel -> True
builtinsList :: MonadNix m => [ Builtin m ]
builtinsList = [
builtinsList :: MonadNix m => m [ Builtin m ]
builtinsList = sequence [
add TopLevel "toString" toString
, add TopLevel "import" import_
, add2 Normal "hasAttr" hasAttr
@ -101,8 +129,8 @@ builtinsList = [
, add2 Normal "all" all_
]
where
add t n v = Builtin t (n, builtin (Text.unpack n) v)
add2 t n v = Builtin t (n, builtin2 (Text.unpack n) v)
add t n v = (\f -> Builtin t (n, f)) <$> builtin (Text.unpack n) v
add2 t n v = (\f -> Builtin t (n, f)) <$> builtin2 (Text.unpack n) v
-- Helpers
@ -138,7 +166,7 @@ hasAttr x y = (,) <$> forceThunk x <*> forceThunk y >>= \case
getAttr :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
getAttr x y = (,) <$> forceThunk x <*> forceThunk y >>= \case
(NVStr key _, NVSet aset) ->
Map.findWithDefault _err key aset
return $ Map.findWithDefault _err key aset
where _err = error ("Field does not exist " ++ Text.unpack key)
(x, y) -> error $ "Invalid types for builtin.hasAttr: "
++ show (() <$ x, () <$ y)
@ -153,7 +181,7 @@ anyM p (x:xs) = do
any_ :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
any_ pred arg = forceThunk arg >>= \case
NVList l ->
mkBool =<< anyM extractBool =<< mapM (evalPred pred) =<< sequence l
mkBool =<< anyM extractBool =<< mapM (evalPred pred) l
arg -> error $ "builtins.any takes a list as second argument, not a "
++ show (() <$ arg)
@ -167,6 +195,6 @@ allM p (x:xs) = do
all_ :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
all_ pred arg = forceThunk arg >>= \case
NVList l ->
mkBool =<< allM extractBool =<< mapM (evalPred pred) =<< sequence l
mkBool =<< allM extractBool =<< mapM (evalPred pred) l
arg -> error $ "builtins.all takes a list as second argument, not a "
++ show (() <$ arg)

153
Nix/Eval.hs
View File

@ -12,6 +12,9 @@ module Nix.Eval (NValue, NValueNF, NValueF(..), ValueSet, MonadNix(..),
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
import Data.Fix
import Data.Functor.Identity
@ -28,7 +31,6 @@ import Nix.Atoms
import Nix.Expr
import Nix.StringOperations (runAntiquoted)
import Nix.Utils
import Debug.Trace
type DList a = Endo [a]
@ -41,8 +43,8 @@ data NValueF m r
| NVStr Text (DList Text)
| NVList [r]
| NVSet (Map.Map Text r)
| NVFunction (Params r) r
-- ^ A function is a closed set of terms representing the "call
| 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
@ -52,11 +54,11 @@ data NValueF m r
| NVLiteralPath FilePath
| NVEnvPath FilePath
| NVBuiltin String (NThunk m -> m (NThunk m))
-- ^ A builtin function can never be normalized beyond this.
-- ^ A builtin function is itself already in normal form.
deriving (Generic, Typeable, Functor)
type NValueNF m = Fix (NValueF m) -- normal form
type NValue m = NValueF m (NThunk m) -- head normal form
type NValueNF m = Fix (NValueF m) -- normal form
type NValue m = NValueF m (NThunk m) -- head normal form
instance Show f => Show (NValueF m f) where
showsPrec = flip go where
@ -114,34 +116,45 @@ atomText (NBool b) = if b then "true" else "false"
atomText NNull = "null"
atomText (NUri uri) = uri
class Monad m => MonadNix m where
class MonadFix m => MonadNix m where
data NThunk m :: *
pushScope :: ValueSet m -> m r -> m r
lookupVar :: Text -> m (Maybe (NThunk m))
importFile :: NThunk m -> m (NThunk m)
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 :: MonadNix m => NValueNF m -> m (NValue m)
wrap :: forall m. MonadNix m => NValueNF m -> m (NThunk m)
wrap = cata phi
where
phi :: NValueF m (m (NValue m)) -> m (NValue m)
phi = undefined
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
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 (FixedParamSet s) m -> go s m
ParamSet (FixedParamSet s) m -> go s m
ParamSet (VariadicParamSet s) m -> go s m
where
go s m = forceThunk arg >>= \case
NVSet args -> do
let res = loeb (alignWithKey assemble args s)
res <- loebM (alignWithKey assemble args s)
maybe (pure res) (selfInject res) m
x -> error $ "Expected set in function call, received: "
++ show (() <$ x)
@ -152,12 +165,12 @@ buildArgument params arg = case params of
return $ Map.insert n ref res
assemble :: Text
-> These (NThunk m) (Maybe (NThunk m))
-> Map.Map Text (m (NThunk m))
-> These (NThunk m) (Maybe (m (NThunk m)))
-> Map.Map Text (NThunk m)
-> m (NThunk m)
assemble k = \case
That Nothing -> error $ "Missing value for parameter: " ++ show k
That (Just f) -> \env -> buildThunk $ pushScope env f
That (Just f) -> \env -> defer $ pushScope env f
This x -> const (pure x)
These x _ -> const (pure x)
@ -167,7 +180,8 @@ evalExpr = cata eval
eval :: MonadNix m => NExprF (m (NThunk m)) -> m (NThunk m)
eval (NSym var) =
eval (NSym var) = do
traceM $ "NSym..1: var = " ++ show var
fromMaybe (error $ "Undefined variable: " ++ show var) <$> lookupVar var
eval (NConstant x) = valueRef $ NVConstant x
@ -228,7 +242,9 @@ eval (NSelect aset attr alternative) = do
aset' <- normalForm =<< aset
ks <- evalSelector True attr
case extract aset' ks of
Just v -> valueRef =<< wrap v
Just v -> do
traceM $ "Wrapping a selector: " ++ show v
wrap v
Nothing -> case alternative of
Just v -> v
Nothing -> error $ "could not look up attribute "
@ -247,16 +263,24 @@ eval (NHasAttr aset attr) = aset >>= forceThunk >>= \case
_ -> error "attr name argument to hasAttr is not a single-part name"
_ -> error "argument to hasAttr has wrong type"
eval (NList l) = valueRef $ NVList l
eval (NList l) = valueRef . NVList =<< sequence l
eval (NSet binds) =
valueRef . NVSet =<< evalBinds True False binds
eval (NSet binds) = do
traceM "NSet..1"
s <- evalBinds True False binds
traceM $ "NSet..2: s = " ++ show (() <$ s)
valueRef $ NVSet s
eval (NRecSet binds) =
valueRef . NVSet =<< evalBinds True True binds
eval (NRecSet binds) = do
traceM "NRecSet..1"
s <- evalBinds True True binds
traceM $ "NRecSet..2: s = " ++ show (() <$ s)
valueRef $ NVSet s
eval (NLet binds e) = do
traceM "Let..1"
s <- evalBinds True True binds
traceM $ "Let..2: s = " ++ show (() <$ s)
pushScope s e
eval (NIf cond t f) = cond >>= forceThunk >>= \case
@ -276,7 +300,6 @@ eval (NAssert cond e) = cond >>= forceThunk >>= \case
eval (NApp fun arg) = fun >>= forceThunk >>= \case
NVFunction params f -> do
args <- buildArgument params =<< arg
traceM $ "args = " ++ show (() <$ args)
pushScope args f
NVBuiltin _ f -> f =<< arg
_ -> error "Attempt to call non-function"
@ -288,11 +311,16 @@ eval (NAbs a b) =
tracingExprEval :: MonadNix m => NExpr -> IO (m (NThunk m))
tracingExprEval =
fmap (runIdentity . snd) . adiM @() (pure <$> eval) psi
flip runReaderT (0 :: Int)
. fmap (runIdentity . snd)
. adiM @() (pure <$> eval) psi
where
psi k v@(Fix x) = do
putStrLn $ "Evaluating: " ++ show x
k v
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
@ -301,12 +329,11 @@ normalForm :: MonadNix m => NThunk m -> m (NValueNF m)
normalForm x = forceThunk x >>= \case
NVConstant a -> return $ Fix $ NVConstant a
NVStr t s -> return $ Fix $ NVStr t s
NVList l -> Fix . NVList <$> (traverse normalForm =<< sequence l)
NVSet s -> Fix . NVSet <$> (traverse normalForm =<< sequence s)
NVList l -> Fix . NVList <$> traverse normalForm l
NVSet s -> Fix . NVSet <$> traverse normalForm s
NVFunction p f -> do
p' <- traverse normalForm =<< sequence p
f' <- normalForm =<< f
return $ Fix $ NVFunction p' f'
p' <- traverse (fmap normalForm) p
return $ Fix $ NVFunction p' (normalForm =<< f)
NVLiteralPath fp -> return $ Fix $ NVLiteralPath fp
NVEnvPath p -> return $ Fix $ NVEnvPath p
NVBuiltin name f -> return $ Fix $ NVBuiltin name f
@ -318,24 +345,25 @@ attrSetAlter :: MonadNix m
-> m (ValueSet m, Maybe (NThunk m))
attrSetAlter [] _ _ = error "invalid selector with no components"
attrSetAlter (p:ps) m f = case Map.lookup p m of
Nothing | null ps -> go Nothing
| otherwise -> recurse Map.empty
Just v | null ps -> go . Just =<< v
| otherwise -> v >>= forceThunk >>= \case
Nothing | null ps -> trace "attrSetAlter..Nothing/null" $ go Nothing
| otherwise -> trace "attrSetAlter..Nothing/otherwise" $ recurse Map.empty
Just v | null ps -> trace "attrSetAlter..Just/null" $ go (Just v)
| otherwise -> trace "attrSetAlter..Just/otherwise" $ forceThunk v >>= \case
NVSet s -> recurse s
_ -> error $ "attribute " ++ attr ++ " is not a set"
where
attr = show (Text.intercalate "." (p:ps))
go mx = f mx >>= \case
go = f >=> \case
Nothing -> return (m, Nothing)
Just v' -> return (Map.insert p (pure v') m, Just v')
Just v' -> return (Map.insert p v' m, Just v')
recurse s = attrSetAlter ps s f >>= \case
(m', mres)
| Map.null m' -> return (m, mres)
| otherwise ->
return (Map.insert p (valueRef (NVSet m')) m, mres)
| otherwise -> do
ref <- valueRef (NVSet m')
return (Map.insert p ref m, mres)
evalBinds :: forall m. MonadNix m
=> Bool
@ -352,13 +380,24 @@ 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
return $ if recursive
then loeb (flip pushScope <$> s)
else s
traceM "buildResult..2"
if recursive
then do
traceM "buildResult..loebM..."
res <- loebM (encapsulate <$> s)
traceM "buildResult..loebM...done"
return res
else trace "buildResult..pure" $ pure s
insert m (path, value) =
fst <$> attrSetAlter path m (const (Just <$> value))
encapsulate f env = defer $ pushScope env (pure f)
insert m (path, value) = do
traceM $ "insert: " ++ show path
res <- fst <$> attrSetAlter path m (const (Just <$> defer value))
traceM $ "inserted: " ++ show path
return res
evalString :: MonadNix m => NString (m (NThunk m)) -> m (NThunk m)
evalString nstr = do
@ -402,17 +441,19 @@ check (NRecSet binds) =
check (NLet binds e) =
(`pushScope` e) =<< evalBinds True True (fmap (fmap (const nullVal)) binds)
check (NAbs a b) = case a of
Param name ->
pushScope (Map.singleton name nullVal) b
ParamSet (FixedParamSet s) Nothing ->
pushScope (nullVal <$ s) b
ParamSet (FixedParamSet s) (Just m) ->
pushScope (Map.insert m nullVal (nullVal <$ s)) b
ParamSet (VariadicParamSet s) Nothing ->
pushScope (nullVal <$ s) b
ParamSet (VariadicParamSet s) (Just m) ->
pushScope (Map.insert m nullVal (nullVal <$ s)) b
check (NAbs a b) = do
nv <- nullVal
case a of
Param name ->
pushScope (Map.singleton name nv) b
ParamSet (FixedParamSet s) Nothing ->
pushScope (nv <$ s) b
ParamSet (FixedParamSet s) (Just m) ->
pushScope (Map.insert m nv (nv <$ s)) b
ParamSet (VariadicParamSet s) Nothing ->
pushScope (nv <$ s) b
ParamSet (VariadicParamSet s) (Just m) ->
pushScope (Map.insert m nv (nv <$ s)) b
-- In order to check some of the other operations properly, we'd need static
-- typing

4
Nix/Pretty.hs
View File

@ -194,8 +194,8 @@ printNix = cata phi
where phi :: NValueF m String -> String
phi (NVConstant a) = unpack $ atomText a
phi (NVStr t _) = unpack t
phi (NVList l) = "[ " ++ (intercalate " " l) ++ " ]"
phi (NVSet s) = intercalate ", " $ [ unpack k ++ ":" ++ v | (k, v) <- toList s]
phi (NVList l) = "[ " ++ unwords l ++ " ]"
phi (NVSet s) = intercalate ", " [ unpack k ++ ":" ++ v | (k, v) <- toList s]
phi (NVFunction _ _) = "<<lambda>>"
phi (NVLiteralPath fp) = fp
phi (NVEnvPath p) = p

19
Nix/Utils.hs
View File

@ -1,14 +1,31 @@
module Nix.Utils where
{-# LANGUAGE CPP #-}
module Nix.Utils (module Nix.Utils, module X) where
import Control.Monad
import Control.Monad.Fix
import Data.Fix
-- #define ENABLE_TRACING 1
#if ENABLE_TRACING
import Debug.Trace as X
#else
import Prelude as X
trace :: String -> a -> a
trace = const id
traceM :: Monad m => String -> m ()
traceM = const (return ())
#endif
(&) :: a -> (a -> c) -> c
(&) = flip ($)
loeb :: Functor f => f (f a -> a) -> f a
loeb x = go where go = fmap ($ go) x
loebM :: (MonadFix m, Traversable t) => t (t a -> m a) -> m (t a)
loebM f = mfix $ \a -> mapM ($ a) f
-- | adi is Abstracting Definitional Interpreters:
--
-- https://arxiv.org/abs/1707.04755

53
main/Main.hs
View File

@ -1,14 +1,17 @@
{-# LANGUAGE MultiWayIf #-}
module Main where
import Control.Monad
import Control.Monad.Trans.State
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 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 ((<$>))
data Options = Options
{ verbose :: Bool
@ -47,33 +50,33 @@ mainOptions = Options
main :: IO ()
main = do
opts <- execParser optsDef
eres <- case expression opts of
Just s -> return $ parseNixString s
Nothing -> case filePath opts of
Just "-" -> parseNixString <$> getContents
Nothing -> parseNixString <$> getContents
Just "-" -> parseNixString <$> getContents
Just path -> parseNixFile path
case eres of
Failure err -> hPutStrLn stderr $ "Parse failed: " ++ show err
Success expr -> do
base <- run baseEnv Map.empty
when (check opts) $
evalStateT (runCyclic (checkExpr expr)) baseEnv
case () of
() | evaluate opts, debug opts -> do
expr' <- tracingExprEval expr
thnk <- evalStateT (runCyclic expr') baseEnv
val <- evalStateT (runCyclic (normalForm thnk))
baseEnv
print val
| evaluate opts ->
putStrLn . printNix =<< evalTopLevelExprIO expr
| debug opts ->
print expr
| otherwise ->
displayIO stdout $ renderPretty 0.4 80 (prettyNix expr)
run (checkExpr expr) base
if | evaluate opts, debug opts -> do
expr' <- tracingExprEval expr
thnk <- run expr' base
val <- run (normalForm thnk) base
print val
| evaluate opts ->
putStrLn . printNix =<< evalTopLevelExprIO expr
| debug opts ->
print expr
| 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")

14
tests/EvalTests.hs
View File

@ -79,11 +79,17 @@ instance (Show r, Eq r) => Eq (NValueF m r) where
constantEqual :: NExpr -> NExpr -> Assertion
constantEqual a b = do
a' <- tracingExprEval a
Fix a' <- evalStateT (runCyclic a') Map.empty
b' <- tracingExprEval b
Fix b' <- evalStateT (runCyclic b') Map.empty
a' <- evaluate a
b' <- evaluate 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 =

13
tests/NixLanguageTests.hs
View File

@ -68,19 +68,26 @@ genTests = do
assertParse :: FilePath -> Assertion
assertParse file = parseNixFile file >>= \case
Success expr -> evalStateT (runCyclic (checkExpr expr)) baseEnv
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)
assertParseFail :: FilePath -> Assertion
assertParseFail file = do
eres <- parseNixFile file
catch (case eres of
Success expr -> do
evalStateT (runCyclic (checkExpr expr)) baseEnv
base <- run baseEnv Map.empty
run (checkExpr expr) base
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
@ -110,7 +117,7 @@ assertEvalFail file = catch eval (\(ErrorCall _) -> return ())
evalResult <- printNix <$> nixEvalFile file
evalResult `seq` assertFailure $ file ++ " should not evaluate.\nThe evaluation result was `" ++ evalResult ++ "`."
nixEvalFile :: FilePath -> IO (NValue (Cyclic IO))
nixEvalFile :: FilePath -> IO (NValueNF (Cyclic IO))
nixEvalFile file = do
parseResult <- parseNixFile file
case parseResult of