Remove an unnecessary layer of indirection in the management of thunks

This commit is contained in:
John Wiegley 2018-03-30 11:53:51 -07:00
parent 3d1bc0bb0b
commit 45d29178df
3 changed files with 244 additions and 213 deletions

View File

@ -41,7 +41,7 @@ evalTopLevelExpr mdir expr = do
case mdir of
Nothing -> return base
Just dir -> do
ref <- valueRef $ Fix $ NVLiteralPath dir
ref <- buildThunk $ return $ NVLiteralPath dir
let m = Map.singleton "__cwd" ref
traceM $ "Setting __cwd = " ++ show dir
return $ extendMap m base
@ -57,7 +57,7 @@ tracingEvalTopLevelExprIO mdir expr = do
base <- case mdir of
Nothing -> run baseEnv emptyMap
Just dir -> do
ref <- run (valueRef $ Fix $ NVLiteralPath dir) emptyMap
ref <- run (buildThunk $ return $ NVLiteralPath dir) emptyMap
let m = Map.singleton "__cwd" ref
traceM $ "Setting __cwd = " ++ show dir
base <- run baseEnv emptyMap
@ -75,7 +75,7 @@ lintExpr expr = run (checkExpr expr) =<< run baseEnv emptyMap
baseEnv :: MonadNix m => m (NestedMap (NThunk m))
baseEnv = do
ref <- buildThunk . NVSet =<< builtins
ref <- buildThunk $ NVSet <$> builtins
lst <- (("builtins", ref) :) <$> topLevelBuiltins
return . NestedMap . (:[]) $ Map.fromList lst
where
@ -86,7 +86,7 @@ newtype Cyclic m a = Cyclic
deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
data Deferred m
= DeferredAction (m (NThunk m))
= DeferredAction (m (NValue m))
-- ^ This is closure over the environment where it was created.
| ComputedValue (NValue m)
@ -102,11 +102,17 @@ instance MonadNix (Cyclic IO) where
clearScopes = Cyclic . local (const (NestedMap [])) . runCyclic
currentScope = Cyclic ask
lookupVar k = Cyclic $ nestedLookup k <$> ask
-- If a variable is being asked for, it's needed in head normal form.
lookupVar k = Cyclic $ do
scope <- ask
case nestedLookup k scope of
Nothing -> return Nothing
Just v -> runCyclic $ Just <$> forceThunk v
-- jww (2018-03-29): Cache which files have been read in.
importFile path = normalForm path >>= \case
Fix (NVLiteralPath path) -> do
importFile = forceThunk >=> \case
NVLiteralPath path -> do
mres <- lookupVar "__cwd"
path' <- case mres of
Nothing -> do
@ -123,13 +129,14 @@ instance MonadNix (Cyclic IO) where
case eres of
Failure err -> error $ "Parse failed: " ++ show err
Success expr -> do
ref <- valueRef $ Fix $ NVLiteralPath $ takeDirectory path'
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 (Map.singleton "__cwd" ref)
(evalExpr expr)
p -> error $ "Unexpected argument to import: " ++ show p
p -> error $ "Unexpected argument to import: " ++ show (() <$ p)
addPath path = liftIO $ do
(exitCode, out, _) <-
@ -138,37 +145,27 @@ instance MonadNix (Cyclic IO) where
ExitSuccess -> return $ StorePath out
_ -> error $ "No such file or directory: " ++ show path
getEnvVar name = normalForm name >>= \case
Fix (NVStr s _) -> do
getEnvVar = forceThunk >=> \case
NVStr s _ -> do
mres <- liftIO $ lookupEnv (Text.unpack s)
case mres of
Nothing -> valueRef $ Fix $ NVStr "" mempty
Just v -> valueRef $ Fix $ NVStr (Text.pack v) mempty
p -> error $ "Unexpected argument to getEnv: " ++ show p
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 (Either (NValueNF (Cyclic IO))
(IORef (Deferred (Cyclic IO))))
valueRef = return . NThunkIO . Left
data NThunk (Cyclic IO) = NThunkIO (IORef (Deferred (Cyclic IO)))
buildThunk action =
liftIO $ NThunkIO . Right <$> newIORef (ComputedValue action)
liftIO $ NThunkIO <$> newIORef (DeferredAction action)
defer action =
liftIO $ NThunkIO . Right <$> newIORef (DeferredAction action)
forceThunk (NThunkIO (Left value)) =
return $ NThunkIO . Left <$> unFix value
forceThunk (NThunkIO (Right ref)) = do
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 <- forceThunk =<< action
value <- action
traceM $ "Forcing thunk computed: " ++ show (() <$ value)
liftIO $ writeIORef ref (ComputedValue value)
return value
@ -190,64 +187,68 @@ builtinsList = sequence [
add TopLevel "toString" toString
, add TopLevel "import" import_
, add Normal "getEnv" getEnv_
, add2 Normal "hasAttr" hasAttr
, add2 Normal "getAttr" getAttr
, add2 Normal "any" any_
, add2 Normal "all" all_
, add3 Normal "foldl'" foldl'_
, add Normal "head" head_
, add Normal "tail" tail_
, add Normal "splitVersion" splitVersion_
, add Normal "getEnv" getEnv_
, add2 Normal "hasAttr" hasAttr
, add2 Normal "getAttr" getAttr
, add2 Normal "any" any_
, add2 Normal "all" all_
-- , add3 Normal "foldl'" foldl'_
, add Normal "head" head_
, add Normal "tail" tail_
, add Normal "splitVersion" splitVersion_
, add2 Normal "compareVersions" compareVersions_
, add2 Normal "compareVersions" compareVersions_
, add2 Normal "sub" sub_
, add Normal "parseDrvName" parseDrvName_
, add2 Normal "sub" sub_
, add Normal "parseDrvName" parseDrvName_
]
where
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
add3 t n v = (\f -> Builtin t (n, f)) <$> builtin3 (Text.unpack n) v
wrap t n f = Builtin t (n, f)
add t n v = wrap t n <$> buildThunk (builtin (Text.unpack n) v)
add2 t n v = wrap t n <$> buildThunk (builtin2 (Text.unpack n) v)
add3 t n v = wrap t n <$> buildThunk (builtin3 (Text.unpack n) v)
-- Helpers
mkBool :: MonadNix m => Bool -> m (NThunk m)
mkBool = valueRef . Fix . NVConstant . NBool
mkBool :: MonadNix m => Bool -> m (NValue m)
mkBool = return . NVConstant . NBool
extractBool :: MonadNix m => NThunk m -> m Bool
extractBool arg = forceThunk arg >>= \case
extractBool :: MonadNix m => NValue m -> m Bool
extractBool = \case
NVConstant (NBool b) -> return b
_ -> error "Not a boolean constant"
apply :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
apply :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
apply f arg = forceThunk f >>= \case
NVFunction params pred ->
(`pushScope` pred) =<< buildArgument params arg
(`pushScope` (forceThunk =<< pred)) =<< buildArgument params arg
x -> error $ "Trying to call a " ++ show (() <$ x)
-- Primops
toString :: MonadNix m => NThunk m -> m (NThunk m)
toString = valueRef . uncurry ((Fix .) . NVStr) <=< valueText <=< normalForm
toString :: MonadNix m => NThunk m -> m (NValue m)
toString str = do
(s, d) <- valueText =<< normalForm =<< forceThunk str
return $ NVStr s d
import_ :: MonadNix m => NThunk m -> m (NThunk m)
import_ :: MonadNix m => NThunk m -> m (NValue m)
import_ = importFile
getEnv_ :: MonadNix m => NThunk m -> m (NThunk m)
getEnv_ :: MonadNix m => NThunk m -> m (NValue m)
getEnv_ = getEnvVar
hasAttr :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
hasAttr :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
hasAttr x y = (,) <$> forceThunk x <*> forceThunk y >>= \case
(NVStr key _, NVSet aset) ->
valueRef $ Fix . NVConstant . NBool $ Map.member key aset
return . NVConstant . NBool $ Map.member key aset
(x, y) -> error $ "Invalid types for builtin.hasAttr: "
++ show (() <$ x, () <$ y)
getAttr :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
getAttr :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
getAttr x y = (,) <$> forceThunk x <*> forceThunk y >>= \case
(NVStr key _, NVSet aset) ->
return $ Map.findWithDefault _err key aset
where _err = error ("Field does not exist " ++ Text.unpack key)
forceThunk (Map.findWithDefault _err key aset)
where _err = error $ "hasAttr: field does not exist: "
++ Text.unpack key
(x, y) -> error $ "Invalid types for builtin.hasAttr: "
++ show (() <$ x, () <$ y)
@ -258,8 +259,8 @@ anyM p (x:xs) = do
if q then return True
else anyM p xs
any_ :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
any_ pred arg = forceThunk arg >>= \case
any_ :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
any_ pred = forceThunk >=> \case
NVList l ->
mkBool =<< anyM extractBool =<< mapM (apply pred) l
arg -> error $ "builtins.any takes a list as second argument, not a "
@ -272,33 +273,35 @@ allM p (x:xs) = do
if q then allM p xs
else return False
all_ :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
all_ pred arg = forceThunk arg >>= \case
all_ :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
all_ pred = forceThunk >=> \case
NVList l ->
mkBool =<< allM extractBool =<< mapM (apply pred) l
arg -> error $ "builtins.all takes a list as second argument, not a "
++ show (() <$ arg)
{-
--TODO: Strictness
foldl'_ :: MonadNix m => NThunk m -> NThunk m -> NThunk m -> m (NThunk m)
foldl'_ f z l = forceThunk l >>= \case
foldl'_ :: MonadNix m => NThunk m -> NThunk m -> NThunk m -> m (NValue m)
foldl'_ f z = forceThunk >=> \case
NVList vals ->
foldlM (\b a -> (f `apply` b) >>= (`apply` a)) z vals
arg -> error $ "builtins.foldl' takes a list as third argument, not a "
++ show (() <$ arg)
-}
head_ :: MonadNix m => NThunk m -> m (NThunk m)
head_ arg = forceThunk arg >>= \case
head_ :: MonadNix m => NThunk m -> m (NValue m)
head_ = forceThunk >=> \case
NVList vals -> case vals of
[] -> error "builtins.head: empty list"
h:_ -> return h
h:_ -> forceThunk h
_ -> error "builtins.head: not a list"
tail_ :: MonadNix m => NThunk m -> m (NThunk m)
tail_ arg = forceThunk arg >>= \case
tail_ :: MonadNix m => NThunk m -> m (NValue m)
tail_ = forceThunk >=> \case
NVList vals -> case vals of
[] -> error "builtins.tail: empty list"
_:t -> buildThunk $ NVList t
_:t -> return $ NVList t
_ -> error "builtins.tail: not a list"
data VersionComponent
@ -332,12 +335,12 @@ splitVersion s = case Text.uncons s of
x -> VersionComponent_String x
in thisComponent : splitVersion rest
splitVersion_ :: MonadNix m => NThunk m -> m (NThunk m)
splitVersion_ arg = forceThunk arg >>= \case
splitVersion_ :: MonadNix m => NThunk m -> m (NValue m)
splitVersion_ = forceThunk >=> \case
NVStr s _ -> do
vals <- forM (splitVersion s) $ \c -> do
buildThunk $ NVStr (versionComponentToString c) mempty
buildThunk $ NVList vals
vals <- forM (splitVersion s) $ \c ->
buildThunk $ return $ NVStr (versionComponentToString c) mempty
return $ NVList vals
_ -> error "builtins.splitVersion: not a string"
compareVersions :: Text -> Text -> Ordering
@ -345,25 +348,25 @@ compareVersions s1 s2 = mconcat $ alignWith f (splitVersion s1) (splitVersion s2
where z = VersionComponent_String ""
f = uncurry compare . fromThese z z
compareVersions_ :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
compareVersions_ :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
compareVersions_ t1 t2 = do
v1 <- forceThunk t1
v2 <- forceThunk t2
case (v1, v2) of
(NVStr s1 _, NVStr s2 _) -> do
buildThunk $ NVConstant $ NInt $ case compareVersions s1 s2 of
return $ NVConstant $ NInt $ case compareVersions s1 s2 of
LT -> -1
EQ -> 0
GT -> 1
_ -> error "builtins.splitVersion: not a string"
sub_ :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
sub_ :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
sub_ t1 t2 = do
v1 <- forceThunk t1
v2 <- forceThunk t2
case (v1, v2) of
(NVConstant (NInt n1), NVConstant (NInt n2)) -> do
buildThunk $ NVConstant $ NInt $ n1 - n2
return $ NVConstant $ NInt $ n1 - n2
_ -> error "builtins.splitVersion: not a number"
parseDrvName :: Text -> (Text, Text)
@ -373,7 +376,8 @@ parseDrvName s =
isFirstVersionPiece p = case Text.uncons p of
Just (h, _) | isDigit h -> True
_ -> False
-- Like 'break', but always puts the first item into the first result list
-- Like 'break', but always puts the first item into the first result
-- list
breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a])
breakAfterFirstItem f = \case
h : t ->
@ -384,13 +388,13 @@ parseDrvName s =
breakAfterFirstItem isFirstVersionPiece pieces
in (Text.intercalate sep namePieces, Text.intercalate sep versionPieces)
parseDrvName_ :: MonadNix m => NThunk m -> m (NThunk m)
parseDrvName_ arg = forceThunk arg >>= \case
parseDrvName_ :: MonadNix m => NThunk m -> m (NValue m)
parseDrvName_ = forceThunk >=> \case
NVStr s _ -> do
let (name, version) = parseDrvName s
vals <- sequence $ Map.fromList
[ ("name", buildThunk $ NVStr name mempty)
, ("version", buildThunk $ NVStr version mempty)
[ ("name", buildThunk $ return $ NVStr name mempty)
, ("version", buildThunk $ return $ NVStr version mempty)
]
buildThunk $ NVSet vals
return $ NVSet vals
_ -> error "builtins.splitVersion: not a string"

View File

@ -54,15 +54,30 @@ data NValueF m r
-- 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 (NThunk m))
-- ^ A builtin function is itself already in normal form.
| 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
@ -87,21 +102,18 @@ instance Show f => Show (NValueF m f) where
. showString " "
. showsPrec 11 b
type ValueSet m = Map.Map Text (NThunk m)
builtin :: MonadNix m => String -> (NThunk m -> m (NThunk m)) -> m (NThunk m)
builtin name f = valueRef $ Fix $ NVBuiltin name f
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 (NThunk m)) -> m (NThunk 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 (NThunk m))
-> m (NThunk m)
builtin3 name f = builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
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
valueText :: forall m. MonadNix m => NValueNF m -> m (Text, DList Text)
valueText = cata phi where
@ -110,13 +122,19 @@ valueText = cata phi where
phi (NVStr t c) = pure (t, c)
phi (NVList _) = error "Cannot coerce a list to a string"
phi (NVSet set)
| Just asString <- Map.lookup "__asString" set = asString --TODO: Should this be run through valueText recursively?
| 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) = pure (Text.pack p, mempty) --TODO: Ensure this is a store path
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
@ -155,26 +173,25 @@ 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))
lookupVar :: Text -> m (Maybe (NValue m))
pushScope :: ValueSet m -> m r -> m r
pushScope = pushScopes . NestedMap . (:[])
data NThunk m :: *
valueRef :: NValueNF m -> m (NThunk m)
buildThunk :: NValue m -> m (NThunk m)
buildThunk :: m (NValue m) -> m (NThunk m)
forceThunk :: NThunk m -> m (NValue m)
defer :: m (NThunk m) -> m (NThunk m)
-- | Import a path into the nix store, and return the resulting path
addPath :: FilePath -> m StorePath
importFile :: NThunk m -> m (NThunk m)
getEnvVar :: NThunk m -> m (NThunk m)
importFile :: NThunk m -> m (NValue m)
getEnvVar :: NThunk m -> m (NValue m)
deferInScope :: MonadNix m
=> NestedMap (NThunk m) -> m (NThunk m) -> m (NThunk m)
deferInScope scope = defer . clearScopes . pushScopes scope
=> NestedMap (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)
@ -195,44 +212,44 @@ buildArgument params arg = case params of
selfInject :: ValueSet m -> Text -> m (ValueSet m)
selfInject res n = do
ref <- buildThunk $ NVSet res
ref <- buildThunk $ pure $ NVSet res
return $ Map.insert n ref res
assemble :: Bool
-> Text
-> These (NThunk m) (Maybe (m (NThunk m)))
-> Map.Map Text (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
defer $ clearScopes $ do
buildThunk $ clearScopes $ do
traceM $ "Evaluating default argument with args: "
++ show (NestedMap [args])
pushScopes (extendMap args scope) f
pushScopes (extendMap 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 (NThunk m)
evalExpr :: MonadNix m => NExpr -> m (NValue m)
evalExpr = cata eval
eval :: MonadNix m => NExprF (m (NThunk m)) -> m (NThunk m)
eval :: MonadNix m => NExprF (m (NValue m)) -> m (NValue m)
eval (NSym var) = do
traceM $ "NSym..1: var = " ++ show var
fromMaybe (error $ "Undefined variable: " ++ show var) <$> lookupVar var
eval (NConstant x) = valueRef $ Fix $ NVConstant x
eval (NConstant x) = return $ NVConstant x
eval (NStr str) = evalString str
eval (NLiteralPath p) = valueRef $ Fix $ NVLiteralPath p
eval (NEnvPath p) = valueRef $ Fix $ NVEnvPath p
eval (NLiteralPath p) = return $ NVLiteralPath p
eval (NEnvPath p) = return $ NVEnvPath p
eval (NUnary op arg) = arg >>= forceThunk >>= \case
NVConstant c -> valueRef $ Fix $ NVConstant $ case (op, c) of
eval (NUnary op arg) = arg >>= \case
NVConstant c -> return $ NVConstant $ case (op, c) of
(NNeg, NInt i) -> NInt (-i)
(NNot, NBool b) -> NBool (not b)
_ -> error $ "unsupported argument type for unary operator "
@ -240,59 +257,69 @@ eval (NUnary op arg) = arg >>= forceThunk >>= \case
_ -> error "argument to unary operator must evaluate to an atomic type"
eval (NBinary op larg rarg) = do
lval <- forceThunk =<< larg
rval <- forceThunk =<< rarg
let unsupportedTypes =
"unsupported argument types for binary operator "
++ show (() <$ lval, op, () <$ rval)
case (lval, rval) of
(NVConstant lc, NVConstant rc) -> case (op, lc, rc) of
(NEq, _, _) -> valueRefBool =<< valueEq lval rval --TODO: Refactor so that eval (NBinary ..) dispatches based on operator first
(NNEq, _, _) -> valueRefBool . not =<< valueEq lval rval
(NLt, l, r) -> valueRefBool $ l < r
(NLte, l, r) -> valueRefBool $ l <= r
(NGt, l, r) -> valueRefBool $ l > r
(NGte, l, r) -> valueRefBool $ l >= r
(NAnd, NBool l, NBool r) -> valueRefBool $ l && r
(NOr, NBool l, NBool r) -> valueRefBool $ l || r
(NImpl, NBool l, NBool r) -> valueRefBool $ not l || r
(NPlus, NInt l, NInt r) -> valueRefInt $ l + r
(NMinus, NInt l, NInt r) -> valueRefInt $ l - r
(NMult, NInt l, NInt r) -> valueRefInt $ l * r
(NDiv, NInt l, NInt r) -> valueRefInt $ l `div` r
_ -> error unsupportedTypes
(NVStr ls lc, NVStr rs rc) -> case op of
NPlus -> valueRef $ Fix $ NVStr (ls `mappend` rs) (lc `mappend` rc)
NEq -> valueRefBool =<< valueEq lval rval
NNEq -> valueRefBool . not =<< valueEq lval rval
_ -> error unsupportedTypes
(NVSet ls, NVSet rs) -> case op of
NUpdate -> buildThunk $ NVSet $ rs `Map.union` ls
_ -> error unsupportedTypes
(NVList ls, NVList rs) -> case op of
NConcat -> buildThunk $ NVList $ ls ++ rs
NEq -> valueRefBool =<< valueEq lval rval
_ -> error unsupportedTypes
(NVLiteralPath ls, NVLiteralPath rs) -> case op of
NPlus -> valueRef $ Fix $ NVLiteralPath $ ls ++ rs -- TODO: Canonicalise path
_ -> error unsupportedTypes
(NVLiteralPath ls, NVStr rs rc) -> case op of
-- TODO: Canonicalise path
NPlus -> valueRef $ Fix $ NVStr (Text.pack ls `mappend` rs) rc
_ -> error unsupportedTypes
_ -> error unsupportedTypes
lval <- larg
rval <- rarg
let unsupportedTypes =
"unsupported argument types for binary operator "
++ show (() <$ lval, op, () <$ rval)
case (lval, rval) of
(NVConstant lc, NVConstant rc) -> case (op, lc, rc) of
(NEq, _, _) ->
-- TODO: Refactor so that eval (NBinary ..) dispatches based
-- on operator first
valueRefBool =<< valueEq lval rval
(NNEq, _, _) -> valueRefBool . not =<< valueEq lval rval
(NLt, l, r) -> valueRefBool $ l < r
(NLte, l, r) -> valueRefBool $ l <= r
(NGt, l, r) -> valueRefBool $ l > r
(NGte, l, r) -> valueRefBool $ l >= r
(NAnd, NBool l, NBool r) -> valueRefBool $ l && r
(NOr, NBool l, NBool r) -> valueRefBool $ l || r
(NImpl, NBool l, NBool r) -> valueRefBool $ not l || r
(NPlus, NInt l, NInt r) -> valueRefInt $ l + r
(NMinus, NInt l, NInt r) -> valueRefInt $ l - r
(NMult, NInt l, NInt r) -> valueRefInt $ l * r
(NDiv, NInt l, NInt r) -> valueRefInt $ l `div` r
_ -> error unsupportedTypes
(NVStr ls lc, NVStr rs rc) -> case op of
NPlus -> return $ NVStr (ls `mappend` rs) (lc `mappend` rc)
NEq -> valueRefBool =<< valueEq lval rval
NNEq -> valueRefBool . not =<< valueEq lval rval
_ -> error unsupportedTypes
(NVSet ls, NVSet rs) -> case op of
NUpdate -> return $ NVSet $ rs `Map.union` ls
_ -> error unsupportedTypes
(NVList ls, NVList rs) -> case op of
NConcat -> return $ NVList $ ls ++ rs
NEq -> valueRefBool =<< valueEq lval rval
_ -> error unsupportedTypes
(NVLiteralPath ls, NVLiteralPath rs) -> case op of
-- TODO: Canonicalise path
NPlus -> return $ NVLiteralPath $ ls ++ rs
_ -> error unsupportedTypes
(NVLiteralPath ls, NVStr rs rc) -> case op of
-- TODO: Canonicalise path
NPlus -> return $ NVStr (Text.pack ls `mappend` rs) rc
_ -> error unsupportedTypes
_ -> error unsupportedTypes
eval (NSelect aset attr alternative) = do
aset' <- forceThunk =<< aset
aset' <- 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 "
pure v
Nothing -> fromMaybe err alternative
where
err = error $ "could not look up attribute "
++ intercalate "." (map Text.unpack ks)
++ " in " ++ show (() <$ aset')
where
@ -304,28 +331,28 @@ eval (NSelect aset attr alternative) = do
extract _ (_:_) = return Nothing
extract v [] = return $ Just v
eval (NHasAttr aset attr) = aset >>= forceThunk >>= \case
eval (NHasAttr aset attr) = aset >>= \case
NVSet s -> evalSelector True attr >>= \case
[keyName] ->
valueRef $ Fix $ NVConstant $ NBool $ keyName `Map.member` s
return $ 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) = do
scope <- currentScope
buildThunk . NVList =<< traverse (deferInScope scope) l
NVList <$> traverse (deferInScope scope) l
eval (NSet binds) = do
traceM "NSet..1"
s <- evalBinds True False binds
traceM $ "NSet..2: s = " ++ show (() <$ s)
buildThunk $ NVSet s
return $ NVSet s
eval (NRecSet binds) = do
traceM "NRecSet..1"
s <- evalBinds True True binds
traceM $ "NRecSet..2: s = " ++ show (() <$ s)
buildThunk $ NVSet s
return $ NVSet s
eval (NLet binds e) = do
traceM "Let..1"
@ -333,29 +360,29 @@ eval (NLet binds e) = do
traceM $ "Let..2: s = " ++ show (() <$ s)
pushScope s e
eval (NIf cond t f) = cond >>= forceThunk >>= \case
eval (NIf cond t f) = cond >>= \case
NVConstant (NBool True) -> t
NVConstant (NBool False) -> f
_ -> error "condition must be a boolean"
eval (NWith scope e) = scope >>= forceThunk >>= \case
eval (NWith scope e) = scope >>= \case
NVSet scope' -> do
env <- currentScope
pushScopes (combineMaps env (NestedMap [scope'])) e
_ -> error "scope must be a set in with statement"
eval (NAssert cond e) = cond >>= forceThunk >>= \case
eval (NAssert cond e) = cond >>= \case
NVConstant (NBool True) -> e
NVConstant (NBool False) -> error "assertion failed"
_ -> error "assertion condition must be boolean"
eval (NApp fun arg) = fun >>= forceThunk >>= \case
eval (NApp fun arg) = fun >>= \case
NVFunction params f -> do
args <- buildArgument params =<< arg
args <- buildArgument params =<< buildThunk arg
traceM $ "Evaluating function application with args: "
++ show (NestedMap [args])
clearScopes (pushScope args f)
NVBuiltin _ f -> f =<< arg
clearScopes (pushScope args (forceThunk =<< f))
NVBuiltin _ f -> f =<< buildThunk arg
_ -> error "Attempt to call non-function"
eval (NAbs params body) = do
@ -365,14 +392,14 @@ eval (NAbs params body) = do
-- body are forced during application.
scope <- currentScope
traceM $ "Creating lambda abstraction in scope: " ++ show scope
buildThunk $ NVFunction (pushScopes scope <$> params)
(pushScopes scope body)
return $ NVFunction (buildThunk . pushScopes scope <$> params)
(buildThunk (pushScopes scope body))
valueRefBool :: MonadNix m => Bool -> m (NThunk m)
valueRefBool = valueRef . Fix . NVConstant . NBool
valueRefBool :: MonadNix m => Bool -> m (NValue m)
valueRefBool = return . NVConstant . NBool
valueRefInt :: MonadNix m => Integer -> m (NThunk m)
valueRefInt = valueRef . Fix . NVConstant . NInt
valueRefInt :: MonadNix m => Integer -> m (NValue m)
valueRefInt = return . NVConstant . NInt
valueEq :: MonadNix m => NValue m -> NValue m -> m Bool
valueEq l r = case (l, r) of
@ -390,7 +417,7 @@ valueEq l r = case (l, r) of
go _ _ = pure False
_ -> pure False
tracingExprEval :: MonadNix m => NExpr -> IO (m (NThunk m))
tracingExprEval :: MonadNix m => NExpr -> IO (m (NValue m))
tracingExprEval =
flip runReaderT (0 :: Int)
. fmap (runIdentity . snd)
@ -406,31 +433,31 @@ tracingExprEval =
exprNormalForm :: MonadNix m => NExpr -> m (NValueNF m)
exprNormalForm = normalForm <=< evalExpr
normalForm :: MonadNix m => NThunk m -> m (NValueNF m)
normalForm x = forceThunk x >>= \case
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 l
NVSet s -> Fix . NVSet <$> traverse normalForm 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) p
return $ Fix $ NVFunction p' (normalForm =<< f)
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
attrSetAlter :: MonadNix m
=> [Text]
-> Map.Map Text (m (NThunk m))
-> m (NThunk m)
-> m (Map.Map Text (m (NThunk m)))
-> Map.Map Text (m (NValue m))
-> m (NValue m)
-> m (Map.Map Text (m (NValue m)))
attrSetAlter [] _ _ = error "invalid selector with no components"
attrSetAlter (p:ps) m val = case Map.lookup p m of
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)
Nothing | null ps -> go
| otherwise -> recurse Map.empty
Just v | null ps -> go
| otherwise -> v >>= \case
NVSet s -> recurse (fmap forceThunk s)
_ -> error $ "attribute " ++ attr ++ " is not a set"
where
attr = show (Text.intercalate "." (p:ps))
@ -443,22 +470,22 @@ attrSetAlter (p:ps) m val = case Map.lookup p m of
scope <- currentScope
return $ Map.insert p (embed scope m') m
where
embed scope m' = buildThunk . NVSet =<< traverse (deferInScope scope) m'
embed scope m' = NVSet <$> traverse (deferInScope scope) m'
evalBinds :: forall m. MonadNix m
=> Bool
-> Bool
-> [Binding (m (NThunk m))]
-> [Binding (m (NValue m))]
-> m (ValueSet m)
evalBinds allowDynamic recursive = buildResult . concat <=< mapM go
where
-- TODO: Inherit
go :: Binding (m (NThunk m)) -> m [([Text], m (NThunk m))]
go :: Binding (m (NValue m)) -> m [([Text], m (NValue m))]
go (NamedVar x y) =
sequence [liftM2 (,) (evalSelector allowDynamic x) (pure y)]
go _ = pure [] -- HACK! But who cares right now
buildResult :: [([Text], m (NThunk m))] -> m (ValueSet m)
buildResult :: [([Text], m (NValue m))] -> m (ValueSet m)
buildResult bindings = do
s <- foldM insert Map.empty bindings
scope <- currentScope
@ -470,28 +497,28 @@ evalBinds allowDynamic recursive = buildResult . concat <=< mapM go
insert m (path, value) = attrSetAlter path m value
evalString :: MonadNix m => NString (m (NThunk m)) -> m (NThunk m)
evalString :: MonadNix m => NString (m (NValue m)) -> m (NValue m)
evalString nstr = do
let fromParts parts = do
(t, c) <- mconcat <$> mapM go parts
valueRef $ Fix $ NVStr t c
return $ NVStr t c
case nstr of
Indented parts -> fromParts parts
DoubleQuoted parts -> fromParts parts
where
go = runAntiquoted (return . (, mempty)) (valueText <=< (normalForm =<<))
evalSelector :: MonadNix m => Bool -> NAttrPath (m (NThunk m)) -> m [Text]
evalSelector :: MonadNix m => Bool -> NAttrPath (m (NValue m)) -> m [Text]
evalSelector dyn = mapM evalKeyName where
evalKeyName (StaticKey k) = return k
evalKeyName (DynamicKey k)
| dyn = do
v <- runAntiquoted evalString id k
v <- runAntiquoted evalString id k
valueTextNoContext =<< normalForm v
| otherwise = error "dynamic attribute not allowed in this context"
nullVal :: MonadNix m => m (NThunk m)
nullVal = valueRef $ Fix $ NVConstant NNull
nullVal :: MonadNix m => m (NValue m)
nullVal = return $ NVConstant NNull
-- | Evaluate an nix expression, with a given ValueSet as environment
checkExpr :: MonadNix m => NExpr -> m ()
@ -517,7 +544,7 @@ check (NLet binds e) =
-- pushScope env e
check (NAbs a b) = do
nv <- nullVal
nv <- buildThunk nullVal
case a of
Param name ->
pushScope (Map.singleton name nv) b

@ -1 +1 @@
Subproject commit 4ee4fda521137fed6af0446948b3877e0c5db803
Subproject commit 71a5161365f40699092e491bbff88473237fc432