diff --git a/Nix/Eval.hs b/Nix/Eval.hs index ece16e1..91b6e0c 100644 --- a/Nix/Eval.hs +++ b/Nix/Eval.hs @@ -4,6 +4,7 @@ import Control.Applicative import Control.Arrow import Control.Monad hiding (mapM) import qualified Data.Map as Map +import Data.Text (Text) import Data.Traversable as T import Nix.Types import Prelude hiding (mapM) @@ -43,20 +44,15 @@ evalExpr = cata phi phi (NArgSet s) = \env -> Fix . NVArgSet <$> mapM (T.sequence . fmap ($ env)) s -- TODO: recursive sets - phi (NSet _b xs) = \env -> - Fix . NVSet . Map.fromList - <$> mapM (fmap (first valueText) . go env) xs - where - go env (x, y) = liftM2 (,) (x env) (y env) + phi (NSet _b binds) = \env -> + Fix . NVSet <$> evalBinds env binds -- TODO: recursive binding phi (NLet binds e) = \env -> case env of (Fix (NVSet env')) -> do - letenv <- Map.fromList <$> mapM (fmap (first valueText) . go) binds + letenv <- evalBinds env binds let newenv = Map.union letenv env' e . Fix . NVSet $ newenv - where - go (x, y) = liftM2 (,) (x env) (y env) _ -> error "invalid evaluation environment" phi (NIf cond t f) = \env -> do @@ -98,3 +94,12 @@ evalExpr = cata phi -- set args <- a env return $ Fix $ NVFunction args b + +evalBinds :: NValue -> [Binding (NValue -> IO NValue)] -> + IO (Map.Map Text NValue) +evalBinds env xs = + Map.fromList <$> mapM (fmap (first valueText)) (concatMap go xs) where + go :: Binding (NValue -> IO NValue) -> [IO (NValue, NValue)] + go (NamedVar x y) = [liftM2 (,) (x env) (y env)] + go (Inherit ys) = map (\y -> (,) <$> y env <*> y env) ys + go (ScopedInherit x ys) = map (\y -> (,) <$> x env <*> y env) ys diff --git a/Nix/Parser.hs b/Nix/Parser.hs index 3bf01fb..b256722 100644 --- a/Nix/Parser.hs +++ b/Nix/Parser.hs @@ -137,11 +137,12 @@ argExpr = (Fix . NArgSet . Map.fromList <$> argList) argName = (,) <$> (identifier <* whiteSpace) <*> optional (symbolic '?' *> nixExpr False) -nvPair :: Parser (NExpr, NExpr) -nvPair = (,) <$> keyName <*> (symbolic '=' *> nixApp) - -nixBinders :: Parser [(NExpr, NExpr)] -nixBinders = nvPair `endBy` symbolic ';' +nixBinders :: Parser [Binding NExpr] +nixBinders = (scopedInherit <|> inherit <|> namedVar) `endBy` symbolic ';' where + scopedInherit = (reserved "inherit" *> whiteSpace *> symbolic '(') *> + (ScopedInherit <$> nixExpr False <* symbolic ')' <*> many keyName) "scoped inherit binding" + inherit = Inherit <$> (reserved "inherit" *> many keyName) "inherited binding" + namedVar = NamedVar <$> keyName <*> (symbolic '=' *> nixApp) "variable binding" keyName :: Parser NExpr keyName = (stringish <|> (mkSym <$> identifier)) <* whiteSpace diff --git a/Nix/Pretty.hs b/Nix/Pretty.hs index 66fbc30..70d6301 100644 --- a/Nix/Pretty.hs +++ b/Nix/Pretty.hs @@ -5,8 +5,10 @@ import Data.Text (Text, unpack) import Nix.Types import Text.PrettyPrint.ANSI.Leijen -prettyBind :: (NExpr, NExpr) -> Doc -prettyBind (n, v) = prettyNix n <+> equals <+> prettyNix v <> semi +prettyBind :: Binding NExpr -> Doc +prettyBind (NamedVar n v) = prettyNix n <+> equals <+> prettyNix v <> semi +prettyBind (Inherit ns) = text "inherit" <+> fillSep (map prettyNix ns) +prettyBind (ScopedInherit s ns) = text "inherit" <+> parens (prettyNix s) <+> fillSep (map prettyNix ns) prettySetArg :: (Text, Maybe NExpr) -> Doc prettySetArg (n, Nothing) = text (unpack n) @@ -62,7 +64,6 @@ prettyNix (Fix expr) = go expr where go (NWith scope body) = text "with" <+> prettyNix scope <> semi <+> prettyNix body go (NAssert cond body) = text "assert" <+> prettyNix cond <> semi <+> prettyNix body - go (NInherit _attrs) = text "inherit" go (NVar e) = prettyNix e go (NApp fun arg) = prettyNix fun <+> parens (prettyNix arg) diff --git a/Nix/Types.hs b/Nix/Types.hs index dd03460..d3c52ed 100644 --- a/Nix/Types.hs +++ b/Nix/Types.hs @@ -99,6 +99,15 @@ instance Show NSetBind where show Rec = "rec" show NonRec = "" +-- | A single line of the bindings section of a let expression. +data Binding r = NamedVar r r | Inherit [r] | ScopedInherit r [r] + deriving (Typeable, Data, Ord, Eq, Functor) + +instance Show r => Show (Binding r) where + show (NamedVar name val) = show name ++ " = " ++ show val ++ ";" + show (Inherit names) = "inherit " ++ concatMap show names ++ ";" + show (ScopedInherit context names) = "inherit (" ++ show context ++ ") " ++ concatMap show names ++ "; " + data NExprF r = NConstant NAtom @@ -107,13 +116,12 @@ data NExprF r | NList [r] -- ^ A "concat" is a list of things which must combine to form a string. | NArgSet (Map Text (Maybe r)) - | NSet NSetBind [(r, r)] + | NSet NSetBind [Binding r] - | NLet [(r, r)] r + | NLet [Binding r] r | NIf r r r | NWith r r | NAssert r r - | NInherit [r] | NVar r | NApp r r @@ -146,15 +154,12 @@ instance Show f => Show (NExprF f) where showArg (k, Nothing) = unpack k showArg (k, Just v) = unpack k ++ " ? " ++ show v - show (NSet b xs) = show b ++ " { " ++ concatMap go xs ++ " }" - where - go (k, v) = show k ++ " = " ++ show v ++ "; " + show (NSet b xs) = show b ++ " { " ++ concatMap show xs ++ " }" show (NLet v e) = "let " ++ show v ++ "; " ++ show e show (NIf i t e) = "if " ++ show i ++ " then " ++ show t ++ " else " ++ show e show (NWith c v) = "with " ++ show c ++ "; " ++ show v show (NAssert e v) = "assert " ++ show e ++ "; " ++ show v - show (NInherit xs) = "inherit " ++ show xs show (NVar v) = show v show (NApp f x) = show f ++ " " ++ show x @@ -171,7 +176,6 @@ dumpExpr = cata phi where phi (NIf i t e) = "NIf " ++ i ++ " " ++ t ++ " " ++ e phi (NWith c v) = "NWith " ++ c ++ " " ++ v phi (NAssert e v) = "NAssert " ++ e ++ " " ++ v - phi (NInherit xs) = "NInherit " ++ show xs phi (NVar v) = "NVar " ++ v phi (NApp f x) = "NApp " ++ f ++ " " ++ x phi (NAbs a b) = "NAbs " ++ a ++ " " ++ b