Merge pull request #9 from jwiegley/inherit

implement inherit in name bindings

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

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

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)

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