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

Remove the MonadFix requirement, it was not needed; fix NRecSet

Browse source
This commit is contained in:
John Wiegley 2018-03-28 23:51:55 -07:00
parent 9a37da33f7
commit 84918aa1d3
6 changed files with 184 additions and 182 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
Nix/Builtins.hs
View file

@ -3,7 +3,6 @@
module Nix.Builtins (baseEnv, builtins,
Cyclic(..), evalTopLevelExpr, evalTopLevelExprIO) where
import Control.Monad.Fix
import Control.Monad.Trans.State
import Data.Fix
import Data.Functor.Identity
@ -19,22 +18,27 @@ import System.IO.Unsafe
-- | Evaluate a nix expression in the default context
evalTopLevelExpr :: MonadNix m => NExpr -> m (NValue m)
evalTopLevelExpr val = newScope baseEnv (evalExpr val)
evalTopLevelExpr = pushScope baseEnv . evalExpr
baseEnv :: MonadNix m => ValueSet m
baseEnv = fmap pure . Map.fromList $
("builtins", Fix $ NVSet builtins) : topLevelBuiltins
baseEnv = fmap pure
. Map.fromList
$ ("builtins", Fix $ NVSet builtins) : topLevelBuiltins
where
topLevelBuiltins = map mapping $ filter isTopLevel builtinsList
-- builtins = Map.fromList $ map mapping $ builtinsList
topLevelBuiltins = map mapping (filter isTopLevel builtinsList)
newtype Cyclic m a = Cyclic { runCyclic :: StateT (ValueSet (Cyclic m)) m a }
deriving (Functor, Applicative, Monad, MonadFix)
deriving (Functor, Applicative, Monad)
instance MonadNix (Cyclic Identity) where
currentScope = Cyclic get
newScope s k = Cyclic $ put s >> runCyclic k
-- currentScope = Cyclic get
-- newScope s k = Cyclic $ put s >> runCyclic k
pushScope s k = Cyclic $ modify (s `Map.union`) >> runCyclic k
lookupVar k = Cyclic $ do
s <- get
case Map.lookup k s of
Nothing -> return Nothing
Just v -> Just <$> runCyclic v
importFile path = Cyclic $ case path of
Fix (NVLiteralPath path) ->
let eres = unsafePerformIO $ parseNixFile path
@ -44,8 +48,14 @@ instance MonadNix (Cyclic Identity) where
_ -> error $ "Unexpected argument to import: " ++ show path
instance MonadNix (Cyclic IO) where
currentScope = Cyclic get
newScope s k = Cyclic $ put s >> runCyclic k
-- currentScope = Cyclic get
-- newScope s k = Cyclic $ put s >> runCyclic k
pushScope s k = Cyclic $ modify (s `Map.union`) >> runCyclic k
lookupVar k = Cyclic $ do
s <- get
case Map.lookup k s of
Nothing -> return Nothing
Just v -> Just <$> runCyclic v
importFile path = Cyclic $ case path of
Fix (NVLiteralPath path) -> do
eres <- parseNixFile path
@ -82,7 +92,6 @@ builtinsList = [
basic = Builtin Normal
topLevel = Builtin TopLevel
-- Helpers
mkBool :: Bool -> NValue m
@ -93,12 +102,10 @@ extractBool (Fix (NVConstant (NBool b))) = b
extractBool _ = error "Not a bool constant"
evalPred :: MonadNix m => NValue m -> NValue m -> m (NValue m)
evalPred (Fix (NVFunction params pred)) arg = do
args <- buildArgument params arg
newScope args pred
evalPred (Fix (NVFunction params pred)) arg =
(`pushScope` pred) =<< buildArgument params arg
evalPred pred _ = error $ "Trying to call a " ++ show pred
-- Primops
prim_toString :: MonadNix m => Functor m => NValue m
@ -114,25 +121,32 @@ import_ = importFile
prim_hasAttr :: MonadNix m => NValue m
prim_hasAttr = builtin2 "hasAttr" hasAttr
hasAttr :: MonadNix m => NValue m -> NValue m -> m (NValue m)
hasAttr (Fix (NVStr key _)) (Fix (NVSet aset)) = return $ Fix $ NVConstant $ NBool $ Map.member key aset
hasAttr key aset = error $ "Invalid types for builtin.hasAttr: " ++ show (key, aset)
hasAttr (Fix (NVStr key _)) (Fix (NVSet aset)) =
return $ Fix $ NVConstant $ NBool $ Map.member key aset
hasAttr key aset =
error $ "Invalid types for builtin.hasAttr: " ++ show (key, aset)
prim_getAttr :: MonadNix m => NValue m
prim_getAttr = builtin2 "getAttr" getAttr
getAttr :: MonadNix m => NValue m -> NValue m -> m (NValue m)
getAttr (Fix (NVStr key _)) (Fix (NVSet aset)) = return $ Map.findWithDefault _err key aset
getAttr (Fix (NVStr key _)) (Fix (NVSet aset)) =
return $ Map.findWithDefault _err key aset
where _err = error ("Field does not exist " ++ Text.unpack key)
getAttr key aset = error $ "Invalid types for builtin.getAttr: " ++ show (key, aset)
getAttr key aset =
error $ "Invalid types for builtin.getAttr: " ++ show (key, aset)
prim_any :: MonadNix m => NValue m
prim_any = builtin2 "any" _any
_any :: MonadNix m => NValue m -> NValue m -> m (NValue m)
_any pred (Fix (NVList l)) = mkBool . any extractBool <$> mapM (evalPred pred) l
_any _ list = error $ "builtins.any takes a list as second argument, not a " ++ show list
_any pred (Fix (NVList l)) =
mkBool . any extractBool <$> mapM (evalPred pred) l
_any _ list =
error $ "builtins.any takes a list as second argument, not a " ++ show list
prim_all :: MonadNix m => NValue m
prim_all = builtin2 "all" _all
_all :: MonadNix m => NValue m -> NValue m -> m (NValue m)
_all pred (Fix (NVList l)) = mkBool . all extractBool <$> mapM (evalPred pred) l
_all _ list = error $ "builtins.all takes a list as second argument, not a " ++ show list
_all pred (Fix (NVList l)) =
mkBool . all extractBool <$> mapM (evalPred pred) l
_all _ list =
error $ "builtins.all takes a list as second argument, not a " ++ show list

217
Nix/Eval.hs
View file

@ -1,7 +1,6 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -11,7 +10,6 @@ module Nix.Eval (NValue, NValueF(..), ValueSet, MonadNix(..),
buildArgument) where
import Control.Monad hiding (mapM, sequence)
import Control.Monad.Fix
import Data.Align.Key
import Data.Fix
import Data.Functor.Identity
@ -23,12 +21,12 @@ import Data.Text (Text)
import qualified Data.Text as Text
import Data.These
import Data.Typeable (Typeable)
import Debug.Trace
import GHC.Generics
import Nix.Atoms
import Nix.Expr
import Nix.StringOperations (runAntiquoted)
import Nix.Utils
import Debug.Trace
type DList a = Endo [a]
@ -112,9 +110,9 @@ atomText (NBool b) = if b then "true" else "false"
atomText NNull = "null"
atomText (NUri uri) = uri
class MonadFix m => MonadNix m where
currentScope :: m (ValueSet m)
newScope :: ValueSet m -> m r -> m r
class Monad m => MonadNix m where
pushScope :: ValueSet m -> m r -> m r
lookupVar :: Text -> m (Maybe (NValue m))
importFile :: NValue m -> m (NValue m)
buildArgument :: forall m. MonadNix m
@ -137,7 +135,7 @@ buildArgument params arg = case params of
-> m (NValue m)
assemble k = \case
That Nothing -> error $ "Missing value for parameter: " ++ show k
That (Just f) -> (`newScope` f)
That (Just f) -> (`pushScope` f)
This x -> const (pure x)
These x _ -> const (pure x)
@ -147,11 +145,8 @@ evalExpr = cata eval
eval :: MonadNix m => NExprF (m (NValue m)) -> m (NValue m)
eval (NSym var) = do
traceM $ "Lookup up " ++ show var
env <- currentScope
fromMaybe (error $ "Undefined variable: " ++ show var)
(Map.lookup var env)
eval (NSym var) =
fromMaybe (error $ "Undefined variable: " ++ show var) <$> lookupVar var
eval (NConstant x) = return $ Fix $ NVConstant x
eval (NStr str) = evalString str
@ -215,7 +210,8 @@ eval (NSelect aset attr alternative) = do
Nothing -> case alternative of
Just v -> v
Nothing -> error $ "could not look up attribute "
++ intercalate "." (map show ks) ++ " in " ++ show aset'
++ intercalate "." (map Text.unpack ks)
++ " in " ++ show aset'
where
extract (Fix (NVSet s)) (k:ks) = case Map.lookup k s of
Just v -> extract v ks
@ -231,24 +227,15 @@ eval (NHasAttr aset attr) = aset >>= \case
eval (NList l) = Fix . NVList <$> sequence l
eval (NSet binds) = do
s <- sequence =<< evalBinds True binds
return $ Fix $ NVSet s
eval (NSet binds) =
-- sequence here means evaluation must be resolved at this point
Fix . NVSet <$> (sequence =<< evalBinds True False binds)
eval (NRecSet binds) = do
env <- currentScope
rec evaledBinds <-
newScope (evaledBinds `Map.union` env)
(evalBinds True binds)
s <- sequence evaledBinds
return $ Fix . NVSet $ s
eval (NRecSet binds) =
Fix . NVSet <$> (sequence =<< evalBinds True True binds)
eval (NLet binds e) = do
env <- currentScope
rec evaledBinds <-
newScope (evaledBinds `Map.union` env)
(evalBinds True binds)
newScope (evaledBinds `Map.union` env) e
eval (NLet binds e) =
(`pushScope` e) =<< evalBinds True True binds
eval (NIf cond t f) = do
Fix cval <- cond
@ -257,19 +244,16 @@ eval (NIf cond t f) = do
NVConstant (NBool False) -> f
_ -> error "condition must be a boolean"
eval (NWith scope e) = do
env <- currentScope
s <- scope
case s of
Fix (NVSet scope') -> newScope (fmap pure scope' `Map.union` env) e
_ -> error "scope must be a set in with statement"
eval (NWith scope e) = scope >>= \case
Fix (NVSet scope') -> pushScope (fmap pure scope') e
_ -> error "scope must be a set in with statement"
eval (NAssert cond e) = do
Fix cond' <- cond
case cond' of
(NVConstant (NBool True)) -> e
(NVConstant (NBool False)) -> error "assertion failed"
_ -> error "assertion condition must be boolean"
Fix cond' <- cond
case cond' of
(NVConstant (NBool True)) -> e
(NVConstant (NBool False)) -> error "assertion failed"
_ -> error "assertion condition must be boolean"
eval (NApp fun x) = do
fun' <- fun
@ -277,23 +261,17 @@ eval (NApp fun x) = do
Fix (NVFunction params f) -> do
arg <- x
args <- buildArgument params arg
newScope args f
traceM $ "args = " ++ show (() <$ args)
pushScope args f
Fix (NVBuiltin _ f) -> do
arg <- x
f arg
_ -> error "Attempt to call non-function"
eval (NAbs a b) = do
env <- currentScope
-- 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
let extend f = do
env' <- currentScope
newScope (env' `Map.union` env) f
return $ Fix $ NVFunction (fmap extend a) (extend b)
eval (NAbs a b) =
-- 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
return $ Fix $ NVFunction a b
tracingExprEval :: MonadNix m => NExpr -> IO (m (NValue m))
tracingExprEval =
@ -316,48 +294,53 @@ evalString nstr = do
Indented parts -> fromParts parts
DoubleQuoted parts -> fromParts parts
evalBinds :: forall m. Monad m
=> Bool -> [Binding (m (NValue m))] -> m (ValueSet m)
evalBinds allowDynamic xs =
buildResult =<< sequence (concatMap go xs)
attrSetAlter :: Monad m
=> [Text]
-> ValueSet m
-> (Maybe (m (NValue m)) -> Maybe (m (NValue m)))
-> m (ValueSet m, Maybe (m (NValue 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 >>= \case
Fix (NVSet s) -> recurse (fmap pure s)
_ -> error $ "attribute " ++ attr ++ " is not a set"
where
attr = show (Text.intercalate "." (p:ps))
go mx = return $ case f mx of
Nothing -> (m, Nothing)
Just v' -> (Map.insert p v' m, Just v')
recurse s = do
(m', mres) <- attrSetAlter ps s f
if Map.null m'
then return (m, mres)
else do
m'' <- sequence m'
return (Map.insert p (return . Fix . NVSet $ m'') m, mres)
evalBinds :: forall m. MonadNix m
=> Bool
-> Bool
-> [Binding (m (NValue m))]
-> m (ValueSet m)
evalBinds allowDynamic recursive = buildResult <=< sequence . concatMap go
where
-- TODO: Inherit
go (NamedVar x y) =
[liftM2 (,) (evalSelector allowDynamic x) (pure y)]
go (NamedVar x y) = [liftM2 (,) (evalSelector allowDynamic x) (pure y)]
go _ = [] -- HACK! But who cares right now
buildResult :: [([Text], m (NValue m))] -> m (ValueSet m)
buildResult =
foldM (\acc (path, value) -> insert acc (reverse path) value)
Map.empty
where
insert :: ValueSet m -> [Text] -> m (NValue m) -> m (ValueSet m)
insert _ [] _ = error "invalid selector with no components"
insert m (p:ps) v =
modifyPath ps (return . insertIfNotMember p v)
where
attr = show $ Text.intercalate "." $ reverse (p:ps)
buildResult bindings = do
s <- foldM insert Map.empty bindings
return $ if recursive
then loeb (flip pushScope <$> s)
else s
modifyPath :: [Text] -> (ValueSet m -> m (ValueSet m))
-> m (ValueSet m)
modifyPath [] f = f m
modifyPath (x:parts) f = modifyPath parts $ \m' ->
case Map.lookup x m' of
Nothing -> return $ Map.singleton x (g Map.empty)
Just s -> s >>= \case
Fix (NVSet m'') ->
return $ Map.insert x (g (fmap pure m'')) m'
_ -> error $ "attribute " ++ attr ++ " already defined"
where
g m = do
s <- sequence =<< f m
return . Fix . NVSet $ s
insertIfNotMember :: Text -> m (NValue m) -> ValueSet m
-> ValueSet m
insertIfNotMember k x m'
| Map.notMember k m' = Map.insert k x m'
| otherwise = error $ "attribute " ++ attr ++ " already defined"
insert m (path, value) = fst <$> attrSetAlter path m (const (Just value))
evalSelector :: Monad m => Bool -> NAttrPath (m (NValue m)) -> m [Text]
evalSelector dyn = mapM evalKeyName where
@ -373,48 +356,32 @@ nullVal = return (Fix (NVConstant NNull) :: NValue m)
checkExpr :: MonadNix m => NExpr -> m ()
checkExpr = cata check
check :: forall m. MonadNix m => NExprF (m ()) -> m ()
check :: MonadNix m => NExprF (m ()) -> m ()
check (NSym var) = do
env <- currentScope
case Map.lookup var env of
Nothing -> error $ "Undefined variable: " ++ show var
Just _ -> return ()
check (NSym var) = lookupVar var >>= \case
Nothing -> error $ "Undefined variable: " ++ show var
Just _ -> return ()
check (NRecSet binds) = do
env <- currentScope
rec evaledBinds <-
newScope ((nullVal <$ evaledBinds) `Map.union` env)
(evalBinds True (fmap (fmap (const nullVal)) binds))
return ()
check (NSet binds) =
sequence_ =<< evalBinds True False (fmap (fmap (const nullVal)) binds)
check (NLet binds e) = do
env <- currentScope
rec evaledBinds <-
newScope ((nullVal <$ evaledBinds) `Map.union` env)
(evalBinds True (fmap (fmap (const nullVal)) binds))
newScope ((nullVal <$ evaledBinds) `Map.union` env) e
check (NRecSet binds) =
sequence_ =<< evalBinds True True (fmap (fmap (const nullVal)) binds)
-- check (NWith scope e) = do
-- env <- currentScope
-- newScope ((nullVal <$ scope) `Map.union` env) e
check (NLet binds e) =
(`pushScope` e) =<< evalBinds True True (fmap (fmap (const nullVal)) binds)
check (NAbs a b) = do
env <- currentScope
let extend f = do
env' <- currentScope
newScope (env' `Map.union` env) f
case fmap extend a of
Param name ->
newScope (Map.singleton name nullVal) (extend b)
ParamSet (FixedParamSet s) Nothing ->
newScope (nullVal <$ s) (extend b)
ParamSet (FixedParamSet s) (Just m) ->
newScope (Map.insert m nullVal (nullVal <$ s)) (extend b)
ParamSet (VariadicParamSet s) Nothing ->
newScope (nullVal <$ s) (extend b)
ParamSet (VariadicParamSet s) (Just m) ->
newScope (Map.insert m nullVal (nullVal <$ s)) (extend b)
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
-- In order to check some of the other operations properly, we'd need static
-- typing

4
default.nix
View file

@ -8,7 +8,7 @@ let
, data-fix, deepseq, deriving-compat, directory, filepath, Glob
, parsers, regex-tdfa, regex-tdfa-text, semigroups, split, stdenv
, tasty, tasty-hunit, tasty-th, text, transformers, trifecta
, unordered-containers, these, optparse-applicative
, unordered-containers, these, optparse-applicative, interpolate
}:
mkDerivation {
pname = "hnix";
@ -27,7 +27,7 @@ let
];
testHaskellDepends = [
base containers data-fix directory filepath Glob split tasty
tasty-hunit tasty-th text transformers
tasty-hunit tasty-th text transformers interpolate
];
benchmarkHaskellDepends = [ base containers criterion text ];
homepage = "http://github.com/jwiegley/hnix";

1
hnix.cabal
View file

@ -129,6 +129,7 @@ Test-suite hnix-tests
, filepath
, split
, transformers
, interpolate
Benchmark hnix-benchmarks
Type: exitcode-stdio-1.0

2
main/Main.hs
View file

@ -65,7 +65,7 @@ main = do
expr' <- tracingExprEval expr
print =<< evalStateT (runCyclic expr') baseEnv
| evaluate opts ->
print =<< evalTopLevelExprIO expr
putStrLn . printNix =<< evalTopLevelExprIO expr
| debug opts ->
print expr
| otherwise ->

76
tests/EvalTests.hs
View file

@ -1,11 +1,13 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module EvalTests (tests) where
import Control.Monad.Trans.State
import Data.Fix
import qualified Data.Map as Map
import Data.String.Interpolate
import Nix.Builtins
import Nix.Eval
import Nix.Expr
@ -14,55 +16,73 @@ import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.TH
case_basic_sum :: Assertion
case_basic_sum = constantEqualStr "2" "1 + 1"
case_basic_sum =
constantEqualStr "2" "1 + 1"
case_basic_function :: Assertion
case_basic_function = constantEqualStr "2" "(a: a) 2"
case_basic_function =
constantEqualStr "2" "(a: a) 2"
case_set_attr :: Assertion
case_set_attr = constantEqualStr "2" "{ a = 2; }.a"
case_set_attr =
constantEqualStr "2" "{ a = 2; }.a"
case_function_set_arg :: Assertion
case_function_set_arg = constantEqualStr "2" "({ a }: 2) { a = 1; }"
case_function_set_arg =
constantEqualStr "2" "({ a }: 2) { a = 1; }"
case_function_set_two_arg :: Assertion
case_function_set_two_arg = constantEqualStr "2" "({ a, b ? 3 }: b - a) { a = 1; }"
case_function_set_two_arg =
constantEqualStr "2" "({ a, b ? 3 }: b - a) { a = 1; }"
case_function_set_two_arg_default_scope :: Assertion
case_function_set_two_arg_default_scope = constantEqualStr "2" "({ x ? 1, y ? x * 3 }: y - x) {}"
case_function_set_two_arg_default_scope =
constantEqualStr "2" "({ x ? 1, y ? x * 3 }: y - x) {}"
case_function_default_env :: Assertion
case_function_default_env = constantEqualStr "2" "let default = 2; in ({ a ? default }: a) {}"
case_function_default_env =
constantEqualStr "2" "let default = 2; in ({ a ? default }: a) {}"
case_function_definition_uses_environment =
constantEqualStr "3" "let f = (let a=1; in x: x+a); in f 2"
case_function_atpattern =
constantEqualStr "2" "(({a}@attrs:attrs) {a=2;}).a"
case_function_definition_uses_environment :: Assertion
case_function_definition_uses_environment = constantEqualStr "3" "let f = (let a=1; in x: x+a); in f 2"
case_function_ellipsis =
constantEqualStr "2" "(({a, ...}@attrs:attrs) {a=0; b=2;}).b"
case_function_atpattern :: Assertion
case_function_atpattern = constantEqualStr "2" "(({a}@attrs:attrs) {a=2;}).a"
case_function_default_value_in_atpattern =
constantEqualStr "2" "({a ? 2}@attrs:attrs.a) {}"
case_function_ellipsis :: Assertion
case_function_ellipsis = constantEqualStr "2" "(({a, ...}@attrs:attrs) {a=0; b=2;}).b"
case_function_recursive_args =
constantEqualStr "2" "({ x ? 1, y ? x * 3}: y - x) {}"
case_function_default_value_in_atpattern :: Assertion
case_function_default_value_in_atpattern = constantEqualStr "2" "({a ? 2}@attrs:attrs.a) {}"
case_function_recursive_sets =
constantEqualStr "[ [ 6 4 100 ] 4 ]" [i|
let x = rec {
case_function_recursive_args :: Assertion
case_function_recursive_args = constantEqualStr "2" "({ x ? 1, y ? x * 3}: y - x) {}"
y = 2;
z = { w = 4; };
v = rec {
u = 6;
t = [ u z.w s ];
};
}; s = 100; in [ x.v.t x.z.w ]
|]
-----------------------
tests :: TestTree
tests = $testGroupGenerator
-----------------------
instance (Show r, Eq r) => Eq (NValueF m r) where
NVConstant x == NVConstant y = x == y
NVList x == NVList y = and (zipWith (==) x y)
x == y = error $ "Need to add comparison for values: "
++ show x ++ " == " ++ show y
constantEqual :: NExpr -> NExpr -> Assertion
constantEqual a b = do
a' <- tracingExprEval a
Fix (NVConstant a') <- evalStateT (runCyclic a') Map.empty
Fix a' <- evalStateT (runCyclic a') Map.empty
b' <- tracingExprEval b
Fix (NVConstant b') <- evalStateT (runCyclic b') Map.empty
Fix b' <- evalStateT (runCyclic b') Map.empty
assertEqual "" a' b'
constantEqualStr :: String -> String -> Assertion