Merge branch 'master' into tests-and-fixes
This commit is contained in:
commit
0aa8fc2602
23
Nix/Eval.hs
23
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)
|
||||
|
@ -40,23 +41,18 @@ evalExpr = cata phi
|
|||
-- Fix . NVConstant . NStr . T.concat
|
||||
-- <$> mapM (fmap valueText . ($ env)) l
|
||||
|
||||
phi (NArgSet s) = \env -> Fix . NVArgSet <$> mapM (T.sequence . fmap ($ env)) s
|
||||
phi (NArgs s) = \env -> Fix . NVArgSet <$> mapM (T.sequence . fmap ($ env)) (formalsAsMap 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
|
||||
|
|
|
@ -19,7 +19,7 @@ nixApp = go <$> someTill (whiteSpace *> nixExpr True) (try (lookAhead stop))
|
|||
where
|
||||
go [] = error "some has failed us"
|
||||
go [x] = x
|
||||
go (f:xs) = Fix (NApp f (go xs))
|
||||
go (f:x:xs) = go (Fix (NApp f x) : xs)
|
||||
|
||||
stop = () <$ oneOf "=,;])}" <|> stopWords <|> eof
|
||||
|
||||
|
@ -101,21 +101,11 @@ nixIf = fmap Fix $ NIf
|
|||
-- or a lambda until we've looked ahead a bit. And then it may be neither,
|
||||
-- in which case we fall back to expected a plain string or identifier.
|
||||
setLambdaStringOrSym :: Bool -> Parser NExpr
|
||||
setLambdaStringOrSym allowLambdas = do
|
||||
isSetOrArgs <- try (lookAhead (reserved "rec") *> pure True)
|
||||
<|> try (lookAhead (singleton <$> char '{') *> pure True)
|
||||
<|> pure False
|
||||
if isSetOrArgs
|
||||
then setOrArgs
|
||||
else do
|
||||
y <- try (lookAhead (True <$ (identifier *> whiteSpace
|
||||
*> symbolic ':')))
|
||||
<|> return False
|
||||
if y
|
||||
then if allowLambdas
|
||||
then setOrArgs
|
||||
else error "Unexpected lambda"
|
||||
else keyName <?> "string"
|
||||
setLambdaStringOrSym True = try nixLambda <|> setLambdaStringOrSym False
|
||||
setLambdaStringOrSym False = try nixSet <|> keyName
|
||||
|
||||
nixLambda :: Parser NExpr
|
||||
nixLambda = Fix <$> (NAbs <$> (argExpr <?> "arguments") <*> nixApp)
|
||||
|
||||
stringish :: Parser NExpr
|
||||
stringish = (char '"' *> (merge <$> manyTill stringChar (char '"')))
|
||||
|
@ -128,45 +118,33 @@ stringish = (char '"' *> (merge <$> manyTill stringChar (char '"')))
|
|||
<|> (mkStr . pack <$> many (noneOf "\"\\"))
|
||||
|
||||
argExpr :: Parser NExpr
|
||||
argExpr = (Fix . NArgSet . Map.fromList <$> argList)
|
||||
<|> ((mkSym <$> identifier) <?> "argname")
|
||||
argExpr = (try (Fix . NArgs . FormalSet <$> paramSet)
|
||||
<|> try (Fix . NArgs . FormalName <$> identifier <* whiteSpace)
|
||||
<|> try (Fix . NArgs <$> (FormalLeftAt <$> identifier <* whiteSpace <*> paramSet))
|
||||
<|> try (Fix . NArgs <$> (FormalRightAt <$> paramSet <*> identifier <* whiteSpace))) <* symbolic ':'
|
||||
where
|
||||
argList = braces ((argName <* whiteSpace) `sepBy` symbolic ',')
|
||||
paramSet :: Parser (FormalParamSet NExpr)
|
||||
paramSet = (FormalParamSet . Map.fromList <$> argList)
|
||||
argList :: Parser [(Text, Maybe NExpr)]
|
||||
argList = braces ((argName <* whiteSpace) `sepBy` symbolic ',') <* symbolic ':'
|
||||
<?> "arglist"
|
||||
|
||||
argName = (,) <$> (identifier <* whiteSpace)
|
||||
argName :: Parser (Text, Maybe NExpr)
|
||||
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
|
||||
|
||||
setOrArgs :: Parser NExpr
|
||||
setOrArgs = do
|
||||
sawRec <- try (reserved "rec" *> pure True) <|> pure False
|
||||
haveSet <-
|
||||
if sawRec
|
||||
then return True
|
||||
else try (lookAhead lookaheadForSet)
|
||||
if haveSet
|
||||
then braces (Fix . NSet (if sawRec then Rec else NonRec) <$> nixBinders) <?> "set"
|
||||
else do
|
||||
args <- argExpr <?> "arguments"
|
||||
symbolic ':' *> fmap Fix (NAbs <$> pure args <*> nixApp)
|
||||
<|> pure args
|
||||
|
||||
lookaheadForSet :: Parser Bool
|
||||
lookaheadForSet = do
|
||||
x <- (symbolic '{' *> return True) <|> return False
|
||||
if not x then return x else do
|
||||
y <- (keyName *> return True) <|> return False
|
||||
if not y then return y else
|
||||
(symbolic '=' *> return True) <|> return False
|
||||
nixSet :: Parser NExpr
|
||||
nixSet = Fix <$> (NSet <$> isRec <*> (braces nixBinders <?> "set")) where
|
||||
isRec = try (reserved "rec" *> pure Rec) <|> pure NonRec
|
||||
|
||||
parseNixFile :: MonadIO m => FilePath -> m (Result NExpr)
|
||||
parseNixFile = parseFromFileEx $ nixApp <* eof
|
||||
|
|
|
@ -5,8 +5,19 @@ 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) <> semi
|
||||
prettyBind (ScopedInherit s ns) = text "inherit" <+> parens (prettyNix s) <+> fillSep (map prettyNix ns) <> semi
|
||||
|
||||
prettyFormals :: Formals -> Doc
|
||||
prettyFormals (FormalName n) = text $ unpack n
|
||||
prettyFormals (FormalSet s) =prettyParamSet s
|
||||
prettyFormals (FormalLeftAt s n) = prettyParamSet s <> text "@" <> text (unpack n)
|
||||
prettyFormals (FormalRightAt n s) text (unpack n) <> text "@" <> prettyParamSet s
|
||||
|
||||
prettyParamSet :: FormalParamSet -> Doc
|
||||
prettyParamSet s = lbrace <+> hcat (map prettySetArg $ toList args) <+> rbrace
|
||||
|
||||
prettySetArg :: (Text, Maybe NExpr) -> Doc
|
||||
prettySetArg (n, Nothing) = text (unpack n)
|
||||
|
@ -48,7 +59,7 @@ prettyNix (Fix expr) = go expr where
|
|||
go (NOper oper) = prettyOper oper
|
||||
go (NList xs) = lbracket <+> fillSep (map prettyNix xs) <+> rbracket
|
||||
|
||||
go (NArgSet args) = lbrace <+> vcat (map prettySetArg $ toList args) <+> rbrace
|
||||
go (NArgs fs) = prettyFormals fs
|
||||
|
||||
go (NSet rec xs) =
|
||||
(case rec of Rec -> "rec"; NonRec -> empty)
|
||||
|
@ -62,7 +73,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)
|
||||
|
|
77
Nix/Types.hs
77
Nix/Types.hs
|
@ -1,3 +1,10 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Nix.Types where
|
||||
|
||||
import Control.Monad hiding (forM_, mapM, sequence)
|
||||
|
@ -99,6 +106,51 @@ 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 FormalParamSet r = FormalParamSet (Map Text (Maybe r))
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Functor)
|
||||
|
||||
instance Show r => Show (FormalParamSet r) where
|
||||
show (FormalParamSet h) = "{ " ++ go (Map.toList h) ++ " }"
|
||||
where
|
||||
go [] = ""
|
||||
go [x] = showArg x
|
||||
go (x:xs) = showArg x ++ ", " ++ go xs
|
||||
|
||||
showArg (k, Nothing) = unpack k
|
||||
showArg (k, Just v) = unpack k ++ " ? " ++ show v
|
||||
|
||||
-- | @Formals@ represents all the ways the formal parameters to a
|
||||
-- function can be represented.
|
||||
data Formals r =
|
||||
FormalName Text |
|
||||
FormalSet (FormalParamSet r) |
|
||||
FormalLeftAt Text (FormalParamSet r) |
|
||||
FormalRightAt (FormalParamSet r) Text
|
||||
deriving (Ord, Eq, Generic, Typeable, Data, Functor)
|
||||
|
||||
instance Show r => Show (Formals r) where
|
||||
show (FormalName n) = show n
|
||||
show (FormalSet s) = show s
|
||||
show (FormalLeftAt n s) = show n ++ "@" ++ show s
|
||||
show (FormalRightAt s n) = show s ++ "@" ++ show n
|
||||
|
||||
-- | @formalsAsMap@ combines the outer and inner name bindings of
|
||||
-- 'Formals'
|
||||
formalsAsMap :: Formals r -> Map Text (Maybe r)
|
||||
formalsAsMap (FormalName n) = Map.singleton n Nothing
|
||||
formalsAsMap (FormalSet (FormalParamSet s)) = s
|
||||
formalsAsMap (FormalLeftAt n (FormalParamSet s)) = Map.insert n Nothing s
|
||||
formalsAsMap (FormalRightAt (FormalParamSet s) n) = Map.insert n Nothing s
|
||||
|
||||
data NExprF r
|
||||
= NConstant NAtom
|
||||
|
||||
|
@ -106,14 +158,13 @@ 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)]
|
||||
| NArgs (Formals 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
|
||||
|
@ -137,24 +188,13 @@ instance Show f => Show (NExprF f) where
|
|||
go [x] = show x
|
||||
go (x:xs) = show x ++ ", " ++ go xs
|
||||
|
||||
show (NArgSet h) = "{ " ++ go (Map.toList h) ++ " }"
|
||||
where
|
||||
go [] = ""
|
||||
go [x] = showArg x
|
||||
go (x:xs) = showArg x ++ ", " ++ go xs
|
||||
|
||||
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 (NArgs fs) = show fs
|
||||
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
|
||||
|
@ -165,13 +205,12 @@ dumpExpr = cata phi where
|
|||
phi (NConstant x) = "NConstant " ++ show x
|
||||
phi (NOper x) = "NOper " ++ show x
|
||||
phi (NList l) = "NList [" ++ show l ++ "]"
|
||||
phi (NArgSet xs) = "NArgSet " ++ show xs
|
||||
phi (NArgs xs) = "NArgs " ++ show xs
|
||||
phi (NSet b xs) = "NSet " ++ show b ++ " " ++ show xs
|
||||
phi (NLet v e) = "NLet " ++ show v ++ " " ++ e
|
||||
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
|
||||
|
|
|
@ -5,7 +5,7 @@
|
|||
cabal.mkDerivation (self: rec {
|
||||
pname = "hnix";
|
||||
version = "0.0.1";
|
||||
src = ./.;
|
||||
src = builtins.filterSource (path: type: type != "unknown") ./.;
|
||||
isLibrary = true;
|
||||
isExecutable = true;
|
||||
noHaddock = true;
|
||||
|
|
Loading…
Reference in a new issue