Remove an unnecessary layer of indirection in the management of thunks
This commit is contained in:
parent
3d1bc0bb0b
commit
45d29178df
174
Nix/Builtins.hs
174
Nix/Builtins.hs
|
@ -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"
|
||||
|
|
281
Nix/Eval.hs
281
Nix/Eval.hs
|
@ -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
|
||||
|
|
2
data/nix
2
data/nix
|
@ -1 +1 @@
|
|||
Subproject commit 4ee4fda521137fed6af0446948b3877e0c5db803
|
||||
Subproject commit 71a5161365f40699092e491bbff88473237fc432
|
Loading…
Reference in New Issue