Initial round of work on supporting first class thunks
This commit is contained in:
John Wiegley
parent
84918aa1d3
commit
e06271d9ca
208
Nix/Builtins.hs
208
Nix/Builtins.hs
|
|
@ -1,11 +1,18 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Nix.Builtins (baseEnv, builtins,
|
||||
Cyclic(..), evalTopLevelExpr, evalTopLevelExprIO) where
|
||||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
||||
|
||||
module Nix.Builtins
|
||||
(baseEnv, builtins, Cyclic(..), evalTopLevelExpr, evalTopLevelExprIO)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.State
|
||||
import Data.Fix
|
||||
import Data.Functor.Identity
|
||||
-- import Data.Fix
|
||||
-- import Data.Functor.Identity
|
||||
import Data.IORef
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
|
|
@ -14,139 +21,152 @@ import Nix.Atoms
|
|||
import Nix.Eval
|
||||
import Nix.Expr (NExpr)
|
||||
import Nix.Parser
|
||||
import System.IO.Unsafe
|
||||
-- import System.IO.Unsafe
|
||||
|
||||
-- | Evaluate a nix expression in the default context
|
||||
evalTopLevelExpr :: MonadNix m => NExpr -> m (NValue m)
|
||||
evalTopLevelExpr = pushScope baseEnv . evalExpr
|
||||
evalTopLevelExpr :: MonadNix m => NExpr -> m (NValueNF m)
|
||||
evalTopLevelExpr = normalForm <=< pushScope baseEnv . evalExpr
|
||||
|
||||
evalTopLevelExprIO :: NExpr -> IO (NValueNF (Cyclic IO))
|
||||
evalTopLevelExprIO expr =
|
||||
evalStateT (runCyclic (evalTopLevelExpr expr)) Map.empty
|
||||
|
||||
baseEnv :: MonadNix m => ValueSet m
|
||||
baseEnv = fmap pure
|
||||
. Map.fromList
|
||||
$ ("builtins", Fix $ NVSet builtins) : topLevelBuiltins
|
||||
baseEnv = Map.fromList
|
||||
$ ("builtins", valueRef $ NVSet builtins) : topLevelBuiltins
|
||||
where
|
||||
topLevelBuiltins = map mapping (filter isTopLevel builtinsList)
|
||||
|
||||
newtype Cyclic m a = Cyclic { runCyclic :: StateT (ValueSet (Cyclic m)) m a }
|
||||
deriving (Functor, Applicative, Monad)
|
||||
|
||||
instance MonadNix (Cyclic Identity) where
|
||||
-- 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
|
||||
in case eres of
|
||||
Failure err -> error $ "Parse failed: " ++ show err
|
||||
Success expr -> runCyclic $ evalExpr expr
|
||||
_ -> error $ "Unexpected argument to import: " ++ show path
|
||||
deriving (Functor, Applicative, Monad, MonadIO)
|
||||
|
||||
instance MonadNix (Cyclic IO) where
|
||||
-- currentScope = Cyclic get
|
||||
-- newScope s k = Cyclic $ put s >> runCyclic k
|
||||
-- jww (2018-03-29): We should use actually stacked scopes here, rather
|
||||
-- than constantly merging maps. The number of scope levels will usually
|
||||
-- be manageable, but the number of attributes within scopes can be
|
||||
-- enormous, making this one of the worst implementations.
|
||||
pushScope s k = Cyclic $ 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
|
||||
|
||||
-- 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
|
||||
eres <- parseNixFile path
|
||||
case eres of
|
||||
Failure err -> error $ "Parse failed: " ++ show err
|
||||
Success expr -> runCyclic $ evalExpr expr
|
||||
_ -> error $ "Unexpected argument to import: " ++ show path
|
||||
p -> error $ "Unexpected argument to import: " ++ show (() <$ p)
|
||||
|
||||
evalTopLevelExprIO :: NExpr -> IO (NValue (Cyclic IO))
|
||||
evalTopLevelExprIO expr =
|
||||
evalStateT (runCyclic (evalTopLevelExpr expr)) Map.empty
|
||||
data NThunk (Cyclic IO) =
|
||||
NThunkIO (IORef (Either (Cyclic IO (NValue (Cyclic IO)))
|
||||
(NValue (Cyclic IO))))
|
||||
|
||||
builtins :: MonadNix m => Map.Map Text (NValue m)
|
||||
buildThunk action = liftIO $ NThunkIO <$> newIORef (Left action)
|
||||
valueRef value = liftIO $ NThunkIO <$> newIORef (Right value)
|
||||
|
||||
forceThunk (NThunkIO ref) = do
|
||||
eres <- liftIO $ readIORef ref
|
||||
case eres of
|
||||
Right value -> return value
|
||||
Left action -> do
|
||||
value <- action
|
||||
liftIO $ writeIORef ref (Right value)
|
||||
return value
|
||||
|
||||
builtins :: MonadNix m => ValueSet m
|
||||
builtins = Map.fromList $ map mapping builtinsList
|
||||
|
||||
data BuiltinType = Normal | TopLevel
|
||||
data Builtin m = Builtin {kind :: BuiltinType, mapping :: (Text, NValue m) }
|
||||
data Builtin m = Builtin
|
||||
{ kind :: BuiltinType
|
||||
, mapping :: (Text, m (NThunk m))
|
||||
}
|
||||
|
||||
isTopLevel :: Builtin m -> Bool
|
||||
isTopLevel b = case kind b of
|
||||
Normal -> False
|
||||
TopLevel -> True
|
||||
isTopLevel b = case kind b of Normal -> False; TopLevel -> True
|
||||
|
||||
builtinsList :: MonadNix m => [ Builtin m ]
|
||||
builtinsList = [
|
||||
topLevel ("toString", prim_toString)
|
||||
, topLevel ("import" , prim_import)
|
||||
, basic ("hasAttr" , prim_hasAttr)
|
||||
, basic ("getAttr" , prim_getAttr)
|
||||
, basic ("any" , prim_any )
|
||||
, basic ("all" , prim_all )
|
||||
add TopLevel "toString" toString
|
||||
, add TopLevel "import" import_
|
||||
, add2 Normal "hasAttr" hasAttr
|
||||
, add2 Normal "getAttr" getAttr
|
||||
, add2 Normal "any" any_
|
||||
, add2 Normal "all" all_
|
||||
]
|
||||
where
|
||||
basic = Builtin Normal
|
||||
topLevel = Builtin TopLevel
|
||||
add t n v = Builtin t (n, builtin (Text.unpack n) v)
|
||||
add2 t n v = Builtin t (n, builtin2 (Text.unpack n) v)
|
||||
|
||||
-- Helpers
|
||||
|
||||
mkBool :: Bool -> NValue m
|
||||
mkBool = Fix . NVConstant . NBool
|
||||
mkBool :: MonadNix m => Bool -> m (NThunk m)
|
||||
mkBool = valueRef . NVConstant . NBool
|
||||
|
||||
extractBool :: NValue m -> Bool
|
||||
extractBool (Fix (NVConstant (NBool b))) = b
|
||||
extractBool _ = error "Not a bool constant"
|
||||
extractBool :: MonadNix m => NThunk m -> m Bool
|
||||
extractBool arg = forceThunk arg >>= \case
|
||||
NVConstant (NBool b) -> return b
|
||||
_ -> error "Not a boolean constant"
|
||||
|
||||
evalPred :: MonadNix m => NValue m -> NValue m -> m (NValue m)
|
||||
evalPred (Fix (NVFunction params pred)) arg =
|
||||
(`pushScope` pred) =<< buildArgument params arg
|
||||
evalPred pred _ = error $ "Trying to call a " ++ show pred
|
||||
evalPred :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
|
||||
evalPred f arg = forceThunk f >>= \case
|
||||
NVFunction params pred ->
|
||||
(`pushScope` pred) =<< buildArgument params arg
|
||||
x -> error $ "Trying to call a " ++ show (() <$ x)
|
||||
|
||||
-- Primops
|
||||
|
||||
prim_toString :: MonadNix m => Functor m => NValue m
|
||||
prim_toString = builtin "toString" toString
|
||||
toString :: MonadNix m => NValue m -> m (NValue m)
|
||||
toString s = return $ Fix $ uncurry NVStr $ valueText s
|
||||
toString :: MonadNix m => NThunk m -> m (NThunk m)
|
||||
toString = valueRef . uncurry NVStr . valueText <=< normalForm
|
||||
|
||||
prim_import :: MonadNix m => Functor m => NValue m
|
||||
prim_import = builtin "import" import_
|
||||
import_ :: MonadNix m => NValue m -> m (NValue m)
|
||||
import_ :: MonadNix m => NThunk m -> m (NThunk m)
|
||||
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 :: MonadNix m => NThunk m -> NThunk m -> m (NThunk m)
|
||||
hasAttr x y = (,) <$> forceThunk x <*> forceThunk y >>= \case
|
||||
(NVStr key _, NVSet aset) ->
|
||||
valueRef $ NVConstant . NBool $ Map.member key aset
|
||||
(x, y) -> error $ "Invalid types for builtin.hasAttr: "
|
||||
++ show (() <$ x, () <$ y)
|
||||
|
||||
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
|
||||
where _err = error ("Field does not exist " ++ Text.unpack key)
|
||||
getAttr key aset =
|
||||
error $ "Invalid types for builtin.getAttr: " ++ show (key, aset)
|
||||
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
|
||||
where _err = error ("Field does not exist " ++ Text.unpack key)
|
||||
(x, y) -> error $ "Invalid types for builtin.hasAttr: "
|
||||
++ show (() <$ x, () <$ y)
|
||||
|
||||
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
|
||||
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
||||
anyM _ [] = return False
|
||||
anyM p (x:xs) = do
|
||||
q <- p x
|
||||
if q then return True
|
||||
else anyM p xs
|
||||
|
||||
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
|
||||
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
|
||||
arg -> error $ "builtins.any takes a list as second argument, not a "
|
||||
++ show (() <$ arg)
|
||||
|
||||
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
||||
allM _ [] = return True
|
||||
allM p (x:xs) = do
|
||||
q <- p x
|
||||
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
|
||||
NVList l ->
|
||||
mkBool =<< allM extractBool =<< mapM (evalPred pred) =<< sequence l
|
||||
arg -> error $ "builtins.all takes a list as second argument, not a "
|
||||
++ show (() <$ arg)
|
||||
|
|
|
|||
282
Nix/Eval.hs
282
Nix/Eval.hs
|
|
@ -3,9 +3,11 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Nix.Eval (NValue, NValueF(..), ValueSet, MonadNix(..),
|
||||
module Nix.Eval (NValue, NValueNF, NValueF(..), ValueSet, MonadNix(..),
|
||||
evalExpr, tracingExprEval, checkExpr,
|
||||
exprNormalForm, normalForm,
|
||||
builtin, builtin2, atomText, valueText,
|
||||
buildArgument) where
|
||||
|
||||
|
|
@ -39,7 +41,7 @@ data NValueF m r
|
|||
| NVStr Text (DList Text)
|
||||
| NVList [r]
|
||||
| NVSet (Map.Map Text r)
|
||||
| NVFunction (Params (m r)) (m r)
|
||||
| NVFunction (Params r) r
|
||||
-- ^ A function is a closed set of terms 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
|
||||
|
|
@ -49,10 +51,12 @@ data NValueF m r
|
|||
-- function.
|
||||
| NVLiteralPath FilePath
|
||||
| NVEnvPath FilePath
|
||||
| NVBuiltin String (NValue m -> m r)
|
||||
| NVBuiltin String (NThunk m -> m (NThunk m))
|
||||
-- ^ A builtin function can never be normalized beyond this.
|
||||
deriving (Generic, Typeable, Functor)
|
||||
|
||||
type NValue m = Fix (NValueF m)
|
||||
type NValueNF m = Fix (NValueF m) -- normal form
|
||||
type NValue m = NValueF m (m (NThunk m)) -- head normal form
|
||||
|
||||
instance Show f => Show (NValueF m f) where
|
||||
showsPrec = flip go where
|
||||
|
|
@ -78,16 +82,16 @@ instance Show f => Show (NValueF m f) where
|
|||
. showString " "
|
||||
. showsPrec 11 b
|
||||
|
||||
type ValueSet m = Map.Map Text (m (NValue m))
|
||||
type ValueSet m = Map.Map Text (m (NThunk m))
|
||||
|
||||
builtin :: String -> (NValue m -> m (NValue m)) -> NValue m
|
||||
builtin name f = Fix (NVBuiltin name f)
|
||||
builtin :: MonadNix m => String -> (NThunk m -> m (NThunk m)) -> m (NThunk m)
|
||||
builtin name f = valueRef $ NVBuiltin name f
|
||||
|
||||
builtin2 :: Monad m
|
||||
=> String -> (NValue m -> NValue m -> m (NValue m)) -> NValue m
|
||||
builtin2 name f = builtin name (return . builtin name . f)
|
||||
builtin2 :: MonadNix m
|
||||
=> String -> (NThunk m -> NThunk m -> m (NThunk m)) -> m (NThunk m)
|
||||
builtin2 name f = builtin name (builtin name . f)
|
||||
|
||||
valueText :: Functor m => NValue m -> (Text, DList Text)
|
||||
valueText :: Functor m => NValueNF m -> (Text, DList Text)
|
||||
valueText = cata phi where
|
||||
phi (NVConstant a) = (atomText a, mempty)
|
||||
phi (NVStr t c) = (t, c)
|
||||
|
|
@ -100,7 +104,7 @@ valueText = cata phi where
|
|||
phi (NVEnvPath p) = (Text.pack p, mempty)
|
||||
phi (NVBuiltin _ _) = error "Cannot coerce a function to a string"
|
||||
|
||||
valueTextNoContext :: Functor m => NValue m -> Text
|
||||
valueTextNoContext :: Functor m => NValueNF m -> Text
|
||||
valueTextNoContext = fst . valueText
|
||||
|
||||
-- | Translate an atom into its nix representation.
|
||||
|
|
@ -111,50 +115,67 @@ atomText NNull = "null"
|
|||
atomText (NUri uri) = uri
|
||||
|
||||
class Monad m => MonadNix m where
|
||||
data NThunk m :: *
|
||||
pushScope :: ValueSet m -> m r -> m r
|
||||
lookupVar :: Text -> m (Maybe (NValue m))
|
||||
importFile :: NValue m -> m (NValue m)
|
||||
lookupVar :: Text -> m (Maybe (NThunk m))
|
||||
importFile :: NThunk m -> m (NThunk m)
|
||||
|
||||
buildThunk :: m (NValue 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 = cata phi
|
||||
where
|
||||
phi :: NValueF m (m (NValue m)) -> m (NValue m)
|
||||
phi = undefined
|
||||
|
||||
buildArgument :: forall m. MonadNix m
|
||||
=> Params (m (NValue m)) -> NValue m -> m (ValueSet m)
|
||||
=> Params (m (NThunk m)) -> NThunk m -> m (ValueSet m)
|
||||
buildArgument params arg = case params of
|
||||
Param name -> return $ Map.singleton name (pure arg)
|
||||
ParamSet (FixedParamSet s) m -> go s m
|
||||
ParamSet (VariadicParamSet s) m -> go s m
|
||||
where
|
||||
go s m = case arg of
|
||||
Fix (NVSet args) -> do
|
||||
go s m = forceThunk arg >>= \case
|
||||
NVSet args -> do
|
||||
let res = loeb (alignWithKey assemble args s)
|
||||
return $ maybe res (selfInject res) m
|
||||
_ -> error $ "Expected set in function call, received: " ++ show arg
|
||||
maybe (pure res) (selfInject res) m
|
||||
x -> error $ "Expected set in function call, received: "
|
||||
++ show (() <$ x)
|
||||
|
||||
selfInject res n = Map.insert n (Fix . NVSet <$> sequence res) res
|
||||
selfInject :: ValueSet m -> Text -> m (ValueSet m)
|
||||
selfInject res n =
|
||||
return $ Map.insert n (valueRef (NVSet res)) res
|
||||
|
||||
assemble :: Text -> These (NValue m) (Maybe (m (NValue m)))
|
||||
-> Map.Map Text (m (NValue m))
|
||||
-> m (NValue m)
|
||||
assemble :: Text
|
||||
-> These (m (NThunk m)) (Maybe (m (NThunk m)))
|
||||
-> ValueSet m
|
||||
-> m (NThunk m)
|
||||
assemble k = \case
|
||||
That Nothing -> error $ "Missing value for parameter: " ++ show k
|
||||
That (Just f) -> (`pushScope` f)
|
||||
This x -> const (pure x)
|
||||
These x _ -> const (pure x)
|
||||
This x -> const x
|
||||
These x _ -> const x
|
||||
|
||||
-- | Evaluate an nix expression, with a given ValueSet as environment
|
||||
evalExpr :: MonadNix m => NExpr -> m (NValue m)
|
||||
evalExpr :: MonadNix m => NExpr -> m (NThunk m)
|
||||
evalExpr = cata eval
|
||||
|
||||
eval :: MonadNix m => NExprF (m (NValue m)) -> m (NValue m)
|
||||
eval :: MonadNix m => NExprF (m (NThunk m)) -> m (NThunk m)
|
||||
|
||||
eval (NSym var) =
|
||||
fromMaybe (error $ "Undefined variable: " ++ show var) <$> lookupVar var
|
||||
|
||||
eval (NConstant x) = return $ Fix $ NVConstant x
|
||||
eval (NConstant x) = valueRef $ NVConstant x
|
||||
eval (NStr str) = evalString str
|
||||
eval (NLiteralPath p) = return $ Fix $ NVLiteralPath p
|
||||
eval (NEnvPath p) = return $ Fix $ NVEnvPath p
|
||||
eval (NLiteralPath p) = valueRef $ NVLiteralPath p
|
||||
eval (NEnvPath p) = valueRef $ NVEnvPath p
|
||||
|
||||
eval (NUnary op arg) = arg >>= \case
|
||||
Fix (NVConstant c) -> return $ Fix $ NVConstant $ case (op, c) of
|
||||
eval (NUnary op arg) = arg >>= forceThunk >>= \case
|
||||
NVConstant c -> valueRef $ NVConstant $ case (op, c) of
|
||||
(NNeg, NInt i) -> NInt (-i)
|
||||
(NNot, NBool b) -> NBool (not b)
|
||||
_ -> error $ "unsupported argument type for unary operator "
|
||||
|
|
@ -162,14 +183,14 @@ eval (NUnary op arg) = arg >>= \case
|
|||
_ -> error "argument to unary operator must evaluate to an atomic type"
|
||||
|
||||
eval (NBinary op larg rarg) = do
|
||||
lval <- larg
|
||||
rval <- rarg
|
||||
lval <- forceThunk =<< larg
|
||||
rval <- forceThunk =<< rarg
|
||||
let unsupportedTypes =
|
||||
"unsupported argument types for binary operator "
|
||||
++ show (lval, op, rval)
|
||||
++ show (() <$ lval, op, () <$ rval)
|
||||
case (lval, rval) of
|
||||
(Fix (NVConstant lc), Fix (NVConstant rc)) ->
|
||||
return $ Fix $ NVConstant $ case (op, lc, rc) of
|
||||
(NVConstant lc, NVConstant rc) ->
|
||||
valueRef $ NVConstant $ case (op, lc, rc) of
|
||||
(NEq, l, r) -> NBool $ l == r
|
||||
(NNEq, l, r) -> NBool $ l /= r
|
||||
(NLt, l, r) -> NBool $ l < r
|
||||
|
|
@ -184,29 +205,29 @@ eval (NBinary op larg rarg) = do
|
|||
(NMult, NInt l, NInt r) -> NInt $ l * r
|
||||
(NDiv, NInt l, NInt r) -> NInt $ l `div` r
|
||||
_ -> error unsupportedTypes
|
||||
(Fix (NVStr ls lc), Fix (NVStr rs rc)) -> case op of
|
||||
NPlus -> return $ Fix $ NVStr (ls `mappend` rs) (lc `mappend` rc)
|
||||
(NVStr ls lc, NVStr rs rc) -> case op of
|
||||
NPlus -> valueRef $ NVStr (ls `mappend` rs) (lc `mappend` rc)
|
||||
_ -> error unsupportedTypes
|
||||
(Fix (NVSet ls), Fix (NVSet rs)) -> case op of
|
||||
NUpdate -> return $ Fix $ NVSet $ rs `Map.union` ls
|
||||
(NVSet ls, NVSet rs) -> case op of
|
||||
NUpdate -> valueRef $ NVSet $ rs `Map.union` ls
|
||||
_ -> error unsupportedTypes
|
||||
(Fix (NVList ls), Fix (NVList rs)) -> case op of
|
||||
NConcat -> return $ Fix $ NVList $ ls ++ rs
|
||||
(NVList ls, NVList rs) -> case op of
|
||||
NConcat -> valueRef $ NVList $ ls ++ rs
|
||||
_ -> error unsupportedTypes
|
||||
(Fix (NVLiteralPath ls), Fix (NVLiteralPath rs)) -> case op of
|
||||
NPlus -> return $ Fix $ NVLiteralPath $ ls ++ rs -- TODO: Canonicalise path
|
||||
(NVLiteralPath ls, NVLiteralPath rs) -> case op of
|
||||
NPlus -> valueRef $ NVLiteralPath $ ls ++ rs -- TODO: Canonicalise path
|
||||
_ -> error unsupportedTypes
|
||||
(Fix (NVLiteralPath ls), Fix (NVStr rs rc)) -> case op of
|
||||
(NVLiteralPath ls, NVStr rs rc) -> case op of
|
||||
-- TODO: Canonicalise path
|
||||
NPlus -> return $ Fix $ NVStr (Text.pack ls `mappend` rs) rc
|
||||
NPlus -> valueRef $ NVStr (Text.pack ls `mappend` rs) rc
|
||||
_ -> error unsupportedTypes
|
||||
_ -> error unsupportedTypes
|
||||
|
||||
eval (NSelect aset attr alternative) = do
|
||||
aset' <- aset
|
||||
aset' <- normalForm =<< aset
|
||||
ks <- evalSelector True attr
|
||||
case extract aset' ks of
|
||||
Just v -> return v
|
||||
Just v -> valueRef =<< wrap v
|
||||
Nothing -> case alternative of
|
||||
Just v -> v
|
||||
Nothing -> error $ "could not look up attribute "
|
||||
|
|
@ -219,61 +240,52 @@ eval (NSelect aset attr alternative) = do
|
|||
extract _ (_:_) = Nothing
|
||||
extract v [] = Just v
|
||||
|
||||
eval (NHasAttr aset attr) = aset >>= \case
|
||||
Fix (NVSet s) -> evalSelector True attr >>= \case
|
||||
[keyName] -> return $ Fix $ NVConstant $ NBool $ keyName `Map.member` s
|
||||
eval (NHasAttr aset attr) = aset >>= forceThunk >>= \case
|
||||
NVSet s -> evalSelector True attr >>= \case
|
||||
[keyName] -> valueRef $ 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) = Fix . NVList <$> sequence l
|
||||
eval (NList l) = valueRef $ NVList l
|
||||
|
||||
eval (NSet binds) =
|
||||
-- sequence here means evaluation must be resolved at this point
|
||||
Fix . NVSet <$> (sequence =<< evalBinds True False binds)
|
||||
valueRef . NVSet =<< evalBinds True False binds
|
||||
|
||||
eval (NRecSet binds) =
|
||||
Fix . NVSet <$> (sequence =<< evalBinds True True binds)
|
||||
valueRef . NVSet =<< evalBinds True True binds
|
||||
|
||||
eval (NLet binds e) =
|
||||
(`pushScope` e) =<< evalBinds True True binds
|
||||
eval (NLet binds e) = do
|
||||
s <- evalBinds True True binds
|
||||
pushScope s e
|
||||
|
||||
eval (NIf cond t f) = do
|
||||
Fix cval <- cond
|
||||
case cval of
|
||||
NVConstant (NBool True) -> t
|
||||
NVConstant (NBool False) -> f
|
||||
_ -> error "condition must be a boolean"
|
||||
eval (NIf cond t f) = cond >>= forceThunk >>= \case
|
||||
NVConstant (NBool True) -> t
|
||||
NVConstant (NBool False) -> f
|
||||
_ -> error "condition must be a boolean"
|
||||
|
||||
eval (NWith scope e) = scope >>= \case
|
||||
Fix (NVSet scope') -> pushScope (fmap pure scope') e
|
||||
eval (NWith scope e) = scope >>= forceThunk >>= \case
|
||||
NVSet scope' -> pushScope 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"
|
||||
eval (NAssert cond e) = cond >>= forceThunk >>= \case
|
||||
NVConstant (NBool True) -> e
|
||||
NVConstant (NBool False) -> error "assertion failed"
|
||||
_ -> error "assertion condition must be boolean"
|
||||
|
||||
eval (NApp fun x) = do
|
||||
fun' <- fun
|
||||
case fun' of
|
||||
Fix (NVFunction params f) -> do
|
||||
arg <- x
|
||||
args <- buildArgument params arg
|
||||
traceM $ "args = " ++ show (() <$ args)
|
||||
pushScope args f
|
||||
Fix (NVBuiltin _ f) -> do
|
||||
arg <- x
|
||||
f arg
|
||||
_ -> error "Attempt to call non-function"
|
||||
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"
|
||||
|
||||
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
|
||||
valueRef $ NVFunction a b
|
||||
|
||||
tracingExprEval :: MonadNix m => NExpr -> IO (m (NValue m))
|
||||
tracingExprEval :: MonadNix m => NExpr -> IO (m (NThunk m))
|
||||
tracingExprEval =
|
||||
fmap (runIdentity . snd) . adiM @() (pure <$> eval) psi
|
||||
where
|
||||
|
|
@ -281,76 +293,94 @@ tracingExprEval =
|
|||
putStrLn $ "Evaluating: " ++ show x
|
||||
k v
|
||||
|
||||
evalString :: Monad m => NString (m (NValue m)) -> m (NValue m)
|
||||
evalString nstr = do
|
||||
let fromParts parts = do
|
||||
(t, c) <-
|
||||
mconcat <$>
|
||||
mapM
|
||||
(runAntiquoted (return . (, mempty)) (fmap valueText))
|
||||
parts
|
||||
return (Fix (NVStr t c))
|
||||
case nstr of
|
||||
Indented parts -> fromParts parts
|
||||
DoubleQuoted parts -> fromParts parts
|
||||
exprNormalForm :: MonadNix m => NExpr -> m (NValueNF m)
|
||||
exprNormalForm = normalForm <=< evalExpr
|
||||
|
||||
attrSetAlter :: Monad m
|
||||
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)
|
||||
NVFunction p f -> do
|
||||
p' <- traverse normalForm =<< sequence p
|
||||
f' <- normalForm =<< f
|
||||
return $ Fix $ NVFunction p' 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]
|
||||
-> ValueSet m
|
||||
-> (Maybe (m (NValue m)) -> Maybe (m (NValue m)))
|
||||
-> m (ValueSet m, Maybe (m (NValue m)))
|
||||
-> (Maybe (NThunk m) -> m (Maybe (NThunk 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 >>= \case
|
||||
Fix (NVSet s) -> recurse (fmap pure s)
|
||||
Just v | null ps -> go . Just =<< v
|
||||
| otherwise -> v >>= forceThunk >>= \case
|
||||
NVSet s -> recurse 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')
|
||||
go mx = f mx >>= \case
|
||||
Nothing -> return (m, Nothing)
|
||||
Just v' -> return (Map.insert p (pure 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)
|
||||
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)
|
||||
|
||||
evalBinds :: forall m. MonadNix m
|
||||
=> Bool
|
||||
-> Bool
|
||||
-> [Binding (m (NValue m))]
|
||||
-> [Binding (m (NThunk m))]
|
||||
-> m (ValueSet m)
|
||||
evalBinds allowDynamic recursive = buildResult <=< sequence . concatMap go
|
||||
evalBinds allowDynamic recursive = buildResult . concat <=< mapM go
|
||||
where
|
||||
-- TODO: Inherit
|
||||
go (NamedVar x y) = [liftM2 (,) (evalSelector allowDynamic x) (pure y)]
|
||||
go _ = [] -- HACK! But who cares right now
|
||||
go :: Binding (m (NThunk m)) -> m [([Text], m (NThunk m))]
|
||||
go (NamedVar x y) =
|
||||
sequence [liftM2 (,) (evalSelector allowDynamic x) (pure y)]
|
||||
go _ = pure [] -- HACK! But who cares right now
|
||||
|
||||
buildResult :: [([Text], m (NValue m))] -> m (ValueSet m)
|
||||
buildResult :: [([Text], m (NThunk m))] -> m (ValueSet m)
|
||||
buildResult bindings = do
|
||||
s <- foldM insert Map.empty bindings
|
||||
return $ if recursive
|
||||
then loeb (flip pushScope <$> s)
|
||||
else s
|
||||
|
||||
insert m (path, value) = fst <$> attrSetAlter path m (const (Just value))
|
||||
insert m (path, value) =
|
||||
fst <$> attrSetAlter path m (const (Just <$> value))
|
||||
|
||||
evalSelector :: Monad m => Bool -> NAttrPath (m (NValue m)) -> m [Text]
|
||||
evalString :: MonadNix m => NString (m (NThunk m)) -> m (NThunk m)
|
||||
evalString nstr = do
|
||||
let fromParts parts = do
|
||||
(t, c) <- mconcat <$> mapM go parts
|
||||
valueRef $ NVStr t c
|
||||
case nstr of
|
||||
Indented parts -> fromParts parts
|
||||
DoubleQuoted parts -> fromParts parts
|
||||
where
|
||||
go = runAntiquoted (return . (, mempty)) (fmap valueText . (normalForm =<<))
|
||||
|
||||
evalSelector :: MonadNix m => Bool -> NAttrPath (m (NThunk m)) -> m [Text]
|
||||
evalSelector dyn = mapM evalKeyName where
|
||||
evalKeyName (StaticKey k) = return k
|
||||
evalKeyName (DynamicKey k)
|
||||
| dyn = fmap valueTextNoContext . runAntiquoted evalString id $ k
|
||||
| dyn = do
|
||||
v <- runAntiquoted evalString id k
|
||||
valueTextNoContext <$> normalForm v
|
||||
| otherwise = error "dynamic attribute not allowed in this context"
|
||||
|
||||
nullVal :: MonadNix m => m (NValue m)
|
||||
nullVal = return (Fix (NVConstant NNull) :: NValue m)
|
||||
nullVal :: MonadNix m => m (NThunk m)
|
||||
nullVal = valueRef (NVConstant NNull)
|
||||
|
||||
-- | Evaluate an nix expression, with a given ValueSet as environment
|
||||
checkExpr :: MonadNix m => NExpr -> m ()
|
||||
|
|
@ -363,10 +393,10 @@ check (NSym var) = lookupVar var >>= \case
|
|||
Just _ -> return ()
|
||||
|
||||
check (NSet binds) =
|
||||
sequence_ =<< evalBinds True False (fmap (fmap (const nullVal)) binds)
|
||||
void $ evalBinds True False (fmap (fmap (const nullVal)) binds)
|
||||
|
||||
check (NRecSet binds) =
|
||||
sequence_ =<< evalBinds True True (fmap (fmap (const nullVal)) binds)
|
||||
void $ evalBinds True True (fmap (fmap (const nullVal)) binds)
|
||||
|
||||
check (NLet binds e) =
|
||||
(`pushScope` e) =<< evalBinds True True (fmap (fmap (const nullVal)) binds)
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ import Data.Maybe (isJust)
|
|||
import Data.Text (pack, unpack, replace, strip)
|
||||
import qualified Data.Text as Text
|
||||
import Nix.Atoms
|
||||
import Nix.Eval (NValue, NValueF (..), atomText)
|
||||
import Nix.Eval (NValueNF, NValueF (..), atomText)
|
||||
import Nix.Expr
|
||||
import Nix.Parser.Library (reservedNames)
|
||||
import Nix.Parser.Operators
|
||||
|
|
@ -171,9 +171,9 @@ prettyNix = withoutParens . cata phi where
|
|||
|
||||
recPrefix = text "rec" <> space
|
||||
|
||||
prettyNixValue :: Functor m => NValue m -> Doc
|
||||
prettyNixValue :: Functor m => NValueNF m -> Doc
|
||||
prettyNixValue = prettyNix . valueToExpr
|
||||
where valueToExpr :: Functor m => NValue m -> NExpr
|
||||
where valueToExpr :: Functor m => NValueNF m -> NExpr
|
||||
valueToExpr = hmap go
|
||||
-- hmap does the recursive conversion from NValue to NExpr
|
||||
-- fun fact: it is not defined in data-fixed, but I was certain it should exists so I found it in unification-fd by hoogling its type
|
||||
|
|
@ -189,7 +189,7 @@ prettyNixValue = prettyNix . valueToExpr
|
|||
go (NVBuiltin name _) = NSym $ Text.pack $ "builtins." ++ name
|
||||
|
||||
|
||||
printNix :: Functor m => NValue m -> String
|
||||
printNix :: Functor m => NValueNF m -> String
|
||||
printNix = cata phi
|
||||
where phi :: NValueF m String -> String
|
||||
phi (NVConstant a) = unpack $ atomText a
|
||||
|
|
|
|||
|
|
@ -63,7 +63,10 @@ main = do
|
|||
case () of
|
||||
() | evaluate opts, debug opts -> do
|
||||
expr' <- tracingExprEval expr
|
||||
print =<< evalStateT (runCyclic expr') baseEnv
|
||||
thnk <- evalStateT (runCyclic expr') baseEnv
|
||||
val <- evalStateT (runCyclic (normalForm thnk))
|
||||
baseEnv
|
||||
print val
|
||||
| evaluate opts ->
|
||||
putStrLn . printNix =<< evalTopLevelExprIO expr
|
||||
| debug opts ->
|
||||
|
|
|
|||
Loading…
Reference in a new issue