language-nix (empty) → 1.0
raw patch · 7 files changed
+841/−0 lines, 7 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, containers, doctest, hspec, language-nix, mtl, parsec, transformers
Files
- LICENSE +30/−0
- Language/Nix.hs +549/−0
- Setup.hs +2/−0
- language-nix.cabal +41/−0
- parse-nix.hs +16/−0
- run-nix.hs +16/−0
- self-test.hs +187/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Peter Simons <simons@cryp.to>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Peter Simons nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Language/Nix.hs view
@@ -0,0 +1,549 @@+{- |+ Module : Language.Nix+ Copyright : (c) 2013 Peter Simons+ License : BSD3+ Maintainer : simons@cryp.to+ -}++module Language.Nix+ (+ -- * Evaluating the Nix Language+ run, runEval, eval, builtins,++ -- * Running the Parser+ parseNixFile, parseNix, parse, parse', ParseError,++ -- * Nix Language AST+ Expr(..), ScopedIdent(..), Attr(..), genIdentifier,++ -- * Nix Language Parsers+ expr, listExpr, term, operatorTable, listOperatorTable, identifier, literal,+ nixString, literalURI, attrSet, scopedIdentifier, attribute, list, letExpr,+ attrSetPattern,++ -- * Parsec Language Specification+ TokenParser, LanguageDef, NixParser, NixOperator, nixLanguage, nixLexer,+ symbol, reserved, reservedOp, lexeme, parens, braces, brackets, natural,+ assign, semi, dot, commaSep1, whitespace,+ )+ where++import Prelude hiding ( lookup )+import Data.Functor.Identity+import Control.Applicative ( (<$>), (<*>), (<$), (<*), (*>) )+import Text.Parsec hiding ( parse )+import qualified Text.Parsec as Parsec+import qualified Text.Parsec.Language as Parsec+import qualified Text.Parsec.Token as Parsec+import Text.Parsec.Expr+import Test.QuickCheck++import Text.Show.Functions ( )+import Control.Monad.Reader+import qualified Control.Monad.Error as ErrT+import Control.Monad.Error hiding ( Error )+import qualified Data.Map as Map ( )+import Data.Map hiding ( map, foldr )++-- import Debug.Trace+trace :: a -> b -> b+trace _ b = b++----- Nix Language Definition for Parsec --------------------------------------++type TokenParser = Parsec.GenTokenParser String () Identity+type LanguageDef = Parsec.GenLanguageDef String () Identity+type NixParser a = ParsecT String () Identity a+type NixOperator = Operator String () Identity Expr++nixLanguage :: LanguageDef+nixLanguage = Parsec.emptyDef+ { Parsec.commentStart = "/*"+ , Parsec.commentEnd = "*/"+ , Parsec.commentLine = "#"+ , Parsec.nestedComments = False+ , Parsec.identStart = letter <|> oneOf "_"+ , Parsec.identLetter = alphaNum <|> oneOf "-_"+ , Parsec.opStart = Parsec.opLetter nixLanguage+ , Parsec.opLetter = oneOf ".!{}[]+=?&|/:"+ , Parsec.reservedOpNames = [".","!","+","++","&&","||","?","=","//","==","!=",":"]+ , Parsec.reservedNames = ["rec","let","in","import","with","inherit","assert","or","if","then","else"]+ , Parsec.caseSensitive = True+ }++nixLexer :: TokenParser+nixLexer = Parsec.makeTokenParser nixLanguage++symbol :: String -> NixParser String+symbol = Parsec.symbol nixLexer++reserved :: String -> NixParser ()+reserved = Parsec.reserved nixLexer++reservedOp :: String -> NixParser ()+reservedOp = Parsec.reservedOp nixLexer++lexeme :: NixParser a -> NixParser a+lexeme = Parsec.lexeme nixLexer++parens :: NixParser a -> NixParser a+parens = Parsec.parens nixLexer++braces :: NixParser a -> NixParser a+braces = Parsec.braces nixLexer++brackets :: NixParser a -> NixParser a+brackets = Parsec.brackets nixLexer++natural :: NixParser String+natural = show <$> Parsec.natural nixLexer++assign :: NixParser String+assign = symbol "="++semi :: NixParser String+semi = Parsec.semi nixLexer++dot :: NixParser String+dot = Parsec.dot nixLexer++commaSep1 :: NixParser a -> NixParser [a]+commaSep1 = Parsec.commaSep1 nixLexer++whitespace :: NixParser ()+whitespace = Parsec.whiteSpace nixLexer++----- Nix Expressions ---------------------------------------------------------++newtype ScopedIdent = SIdent [String]+ deriving (Read, Show, Eq)++data Attr = Assign ScopedIdent Expr+ | Inherit ScopedIdent [String]+ deriving (Read, Show, Eq)++genIdentifier :: Gen String+genIdentifier = ((:) <$> elements firstChar <*> listOf (elements identChar)) `suchThat` (`notElem` Parsec.reservedNames nixLanguage)+ where firstChar = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+ identChar = firstChar ++ ['0'..'9'] ++ "-"++instance Arbitrary ScopedIdent where+ arbitrary = SIdent <$> listOf1 genIdentifier++data Expr = Null+ | Lit String+ | Ident String+ | Boolean Bool+ | AttrSet Bool [Attr]+ | AttrSetP (Maybe String) [(String, Maybe Expr)]+ | List [Expr]+ | Deref Expr Expr+ | HasAttr Expr Expr+ | DefAttr Expr Expr+ | Concat Expr Expr+ | Append Expr Expr+ | Not Expr+ | Union Expr Expr+ | Equal Expr Expr+ | Inequal Expr Expr+ | And Expr Expr+ | Or Expr Expr+ | Implies Expr Expr+ | Fun Expr Expr+ | Let [Attr] Expr+ | Apply Expr Expr+ | Import Expr+ | With Expr+ | Assert Expr+ | IfThenElse Expr Expr Expr+ deriving (Read, Show, Eq)++expr :: NixParser Expr+expr = whitespace >> buildExpressionParser operatorTable term++listExpr :: NixParser Expr+listExpr = buildExpressionParser listOperatorTable term++term :: NixParser Expr+term = choice [ parens expr+ , list+ , try attrSetPattern+ , attrSet+ , letExpr+ , reserved "import" >> Import <$> expr+ , reserved "with" >> With <$> expr <* semi+ , reserved "assert" >> Assert <$> expr <* semi+ , IfThenElse <$> (reserved "if" *> expr) <*> (reserved "then" *> expr) <*> (reserved "else" *> expr)+ , try literal+ , identifier+ ]++operatorTable :: [[NixOperator]]+operatorTable = x1 : x2 : [ Infix (Apply <$ whitespace) AssocLeft ] : xs+ where (x1:x2:xs) = listOperatorTable++listOperatorTable :: [[NixOperator]]+listOperatorTable = [ [ binary "." Deref AssocLeft ]+ , [ binary "or" DefAttr AssocNone ]+ {- , [ Infix (Apply <$ whitespace) AssocRight ] -}+ , [ binary "?" HasAttr AssocNone ]+ , [ binary "++" Concat AssocRight ]+ , [ binary "+" Append AssocLeft ]+ , [ prefix "!" Not ]+ , [ binary "//" Union AssocRight ]+ , [ binary "==" Equal AssocNone ]+ , [ binary "!=" Inequal AssocNone ]+ , [ binary "&&" And AssocLeft ]+ , [ binary "||" Or AssocLeft ]+ , [ binary "->" Implies AssocNone ]+ , [ binary ":" Fun AssocRight ]+ ]+ where+ binary :: String -> (Expr -> Expr -> Expr) -> Assoc -> NixOperator+ binary op fun = Infix (fun <$ reservedOp op)++ prefix :: String -> (Expr -> Expr) -> NixOperator+ prefix op fun = Prefix (fun <$ reservedOp op)++identifier :: NixParser Expr+identifier = Ident <$> Parsec.identifier nixLexer++literal :: NixParser Expr+literal = Lit <$> (stringLiteral <|> nixString <|> natural <|> literalURI)++stringLiteral :: NixParser String+stringLiteral = lexeme $ between (string "\"") (string "\"") (concat <$> many stringChar)+ where+ stringChar :: NixParser String+ stringChar = choice [ many1 (noneOf "$\\\"")+ , try $ char '$' >> braces expr >> return ""+ , return <$> char '$'+ , char '\\' >> anyChar >>= \c -> return ['\\',c]+ ]++nixString :: NixParser String+nixString = lexeme $ between (string "''") (string "''") (concat <$> many stringChar)+ where+ stringChar :: NixParser String+ stringChar = choice [ many1 (noneOf "$'")+ , try $ char '$' >> braces expr >> return ""+ , return <$> char '$'+ , try $ (return <$> char '\'') <* notFollowedBy (char '\'')+ , try $ string "''" >> string "${"+ ]++literalURI :: NixParser String+literalURI = lexeme $ try absoluteURI <|> relativeURI++absoluteURI :: NixParser String+absoluteURI = (++) <$> scheme <*> ((:) <$> char ':' <*> (hierPart <|> opaquePart))++relativeURI :: NixParser String+relativeURI = (++) <$> (absPath <|> relPath) <*> option "" (char '?' >> query)++absPath :: NixParser String+absPath = (:) <$> char '/' <*> pathSegments++authority :: NixParser String+authority = server <|> regName++domainlabel :: NixParser String+domainlabel = (:) <$> alphaNum <*> option "" ((++) <$> many (char '-') <*> domainlabel)++escapedChars :: NixParser Char+escapedChars = char '%' >> hexDigit >> hexDigit++hierPart :: NixParser String+hierPart = (++) <$> (try netPath <|> absPath) <*> option "" (char '?' >> query)++host :: NixParser String+host = hostname <|> ipv4address++hostname :: NixParser String+hostname = many (domainlabel >> char '.') >> toplabel >> option "" (string ".")++hostport :: NixParser String+hostport = (++) <$> host <*> option "" ((:) <$> char ':' <*> port)++ipv4address :: NixParser String+ipv4address = many1 digit >> char '.' >> many1 digit >> char '.' >> many1 digit >> char '.' >> many1 digit++markChars :: NixParser Char+markChars = oneOf "-_.!~*'" -- Note that "()" have been removed here!++netPath :: NixParser String+netPath = (++) <$> ((++) <$> string "//" <*> authority) <*> option "" absPath++opaquePart :: NixParser String+opaquePart = uricNoSlash >> many uric++pathSegments :: NixParser String+pathSegments = (++) <$> segment <*> (concat <$> many ((:) <$> char '/' <*> segment))++pchar :: NixParser Char+pchar = unreservedChars <|> escapedChars <|> oneOf ":@&=+$,"++port :: NixParser String+port = many1 digit++query :: NixParser String+query = many uric++regName :: NixParser String+regName = many1 (unreservedChars <|> escapedChars <|> oneOf "$,:@&=+") -- Note that ';' has been removed here!++relPath :: NixParser String+relPath = (++) <$> relSegment <*> absPath++relSegment :: NixParser String+relSegment = many1 (unreservedChars <|> escapedChars <|> oneOf "@&=+$,") -- Note that ';' has been removed here!++reservedChars :: NixParser Char+reservedChars = oneOf "/?:@&=+$," -- Note that ';' has been removed here!++scheme :: NixParser String+scheme = (:) <$> letter <*> many (alphaNum <|> oneOf "+-.")++segment :: NixParser String+segment = {- (++) <$> -} many pchar {- <*> (concat <$> many ((:) <$> char ';' <*> param)) -}++server :: NixParser String+server = option "" (option "" ((++) <$> userinfo <*> string "@") >> hostport)++toplabel :: NixParser Char+toplabel = letter <|> (letter >> many (alphaNum <|> char '-') >> alphaNum)++unreservedChars :: NixParser Char+unreservedChars = alphaNum <|> markChars++uric :: NixParser Char+uric = reservedChars <|> unreservedChars <|> escapedChars++uricNoSlash :: NixParser Char+uricNoSlash = unreservedChars <|> escapedChars <|> oneOf ";?:@&=+$,"++userinfo :: NixParser String+userinfo = many (unreservedChars <|> escapedChars <|> oneOf ";:&=+$,")++attrSet :: NixParser Expr+attrSet = AttrSet <$> option False (True <$ reserved "rec") <*> braces (attribute `endBy` semi)++scopedIdentifier :: NixParser ScopedIdent+scopedIdentifier = SIdent <$> sepBy1 (Parsec.identifier nixLexer) dot++attribute :: NixParser Attr+attribute = (Assign <$> (SIdent . return <$> stringLiteral <|> scopedIdentifier) <* assign <*> expr)+ <|> (Inherit <$> (symbol "inherit" *> option (SIdent []) (parens scopedIdentifier)) <*> many1 (Parsec.identifier nixLexer))++list :: NixParser Expr+list = List <$> brackets (many listExpr)++attrSetPattern :: NixParser Expr+attrSetPattern = AttrSetP <$> optionMaybe atPattern <*> setPattern+ where+ atPattern = Parsec.identifier nixLexer <* reserved "@"+ setPattern = braces $ commaSep1 $ (,) <$> Parsec.identifier nixLexer <*> optionMaybe (reservedOp "?" >> expr) <|> ellipsis+ ellipsis = ("...",Nothing) <$ reserved "..."++letExpr :: NixParser Expr+letExpr = choice [ try $ Let <$> (reserved "let" *> try attribute `endBy1` semi) <*> (reserved "in" *> expr)+ , (`Let` Ident "body") <$> (reserved "let" *> braces (try attribute `endBy1` semi))+ ]++parseNixFile :: FilePath -> IO (Either ParseError Expr)+parseNixFile path = parse' (expr <* eof) path <$> readFile path++parseNix :: String -> Either ParseError Expr+parseNix = parse expr++parse' :: NixParser a -> SourceName -> String -> Either ParseError a+parse' = Parsec.parse++parse :: NixParser a -> String -> Either ParseError a+parse p = parse' (p <* eof) "<string>"++----- Nix Evaluation ----------------------------------------------------------++type VarName = String+type Env = Map VarName Expr++data Error = CannotCoerceToString Expr+ | CannotCoerceToBool Expr+ | TypeMismatch Expr+ | UndefinedVariable VarName+ | Unsupported Expr+ | Unstructured String+ | InvalidSyntax ParseError+ deriving (Show)++instance ErrT.Error Error where+ strMsg = Unstructured+ noMsg = Unstructured "no error message available"++type Eval a = ErrorT Error (Reader Env) a++getEnv :: VarName -> Eval Expr+getEnv v = ask >>= maybe (throwError (UndefinedVariable v)) return . lookup v++onError :: Eval a -> (Error -> Bool, Eval a) -> Eval a+onError f (p,g) = catchError f (\e -> if p e then g else throwError e)++isUndefinedVariable :: Error -> Bool+isUndefinedVariable (UndefinedVariable _) = True+isUndefinedVariable _ = False++isCoerceToString :: Error -> Bool+isCoerceToString (CannotCoerceToString _) = True+isCoerceToString _ = False++isCoerceToBool :: Error -> Bool+isCoerceToBool (CannotCoerceToBool _) = True+isCoerceToBool _ = False++evalBool :: Expr -> Eval Bool+evalBool e | trace ("evalBool " ++ show e) False = undefined+evalBool (Boolean x) = return x+evalBool (Ident v) = getEnv v >>= evalBool+evalBool (And x y) = (&&) <$> evalBool x <*> evalBool y+evalBool (Or x y) = (||) <$> evalBool x <*> evalBool y+evalBool (Not x) = not <$> evalBool x+evalBool e@(Equal x y) = ((==) <$> evalString x <*> evalString y)+ `onError` (isCoerceToString, (==) <$> evalBool x <*> evalBool y)+ `onError` (isCoerceToBool, throwError (TypeMismatch e))+evalBool e = throwError (CannotCoerceToBool e)++evalString :: Expr -> Eval String+evalString e | trace ("evalString " ++ show e) False = undefined+evalString (Lit x) = return x+evalString (Append x y) = (++) <$> evalString x <*> evalString y+evalString (Ident v) = getEnv v >>= evalString+evalString e = throwError (CannotCoerceToString e)++evalAttribute :: Attr -> Eval [(VarName,Expr)]+evalAttribute (Assign (SIdent [k]) v) = (return . (,) k) <$> eval v+evalAttribute (Inherit (SIdent []) vs) = sequence [ (,) v <$> getEnv v | v <- vs ]+evalAttribute e = throwError (Unsupported (AttrSet False [e]))++attrSetToEnv :: Attr -> Eval [(VarName,Expr)]+attrSetToEnv (Assign (SIdent [k]) v) = return [(k,v)]+attrSetToEnv (Inherit (SIdent []) vs) = sequence [ (,) v <$> getEnv v | v <- vs ]+attrSetToEnv e = throwError (Unsupported (AttrSet True [e]))++eval :: Expr -> Eval Expr+eval e | trace ("eval " ++ show e) False = undefined+eval Null = return Null+eval e@(Lit _) = return e+eval e@(Boolean _) = return e+eval (Ident v) = getEnv v >>= eval+eval e@(Append _ _) = Lit <$> evalString e+eval e@(And _ _) = Boolean <$> evalBool e+eval e@(Or _ _) = Boolean <$> evalBool e+eval e@(Not _) = Boolean <$> evalBool e+eval e@(Equal _ _) = Boolean <$> evalBool e+eval e@(Inequal _ _) = Boolean <$> evalBool e+eval (IfThenElse b x y) = evalBool b >>= \b' -> eval (if b' then x else y)+eval (DefAttr x y) = eval x `onError` (isUndefinedVariable, eval y)+eval (Let as e) = concat <$> mapM attrSetToEnv as >>= \env -> trace ("add to env: " ++ show env) $ local (union (fromList env)) (eval e)+eval (Apply (Fun (Ident v) x) y) = trace "foo" $ eval y >>= \y' -> local (insert v y') (eval x)+eval (Apply (Ident v) y) = trace "yo" $ getEnv v >>= \x' -> eval (Apply x' y)+eval (Apply x@(Apply _ _) y) = trace "yo" $ eval x >>= \x' -> eval (Apply x' y)+eval (AttrSet False as) = (AttrSet False . map (\(k,v) -> Assign (SIdent [k]) v) . concat) <$> mapM evalAttribute as+eval (AttrSet True as) = concat <$> mapM attrSetToEnv as >>= \as' -> trace ("add to env: " ++ show as') $ local (union (fromList as')) (eval (AttrSet False as))+eval (Deref (Ident v) y) = getEnv v >>= \v' -> eval (Deref v' y)+eval (Deref (AttrSet False as) y@(Ident _)) = concat <$> mapM evalAttribute as >>= \as' -> trace ("add to env: " ++ show as') $ local (\env -> foldr (uncurry insert) env as') (eval y)+eval (Deref (AttrSet True as) y@(Ident _)) = concat <$> mapM attrSetToEnv as >>= \as' -> trace ("add to env: " ++ show as') $ local (\env -> foldr (uncurry insert) env as') (eval y)+eval e@(Deref _ _) = throwError (TypeMismatch e)+eval e = throwError (Unsupported e)++--+-- eval (Apply (Lambda v x) y) = eval y >>= \y' -> trace ("add to env: " ++ show (v,y')) $ local ((v,y'):) (eval x)+-- eval (Apply x@(V _) y) = eval x >>= \x' -> eval (Apply x' y)+-- eval (Apply x@(Apply _ _) y) = eval x >>= \x' -> eval (Apply x' y)+-- eval (Let env e) = trace ("add to env: " ++ show env) $ local (env++) (eval e)+-- eval e@(Lambda _ _) = return e+-- eval e = throwError (Unsupported e)+++-- coerceDict :: Value -> Dict+-- coerceDict (AttrSetV e) = e+-- coerceDict e = error ("cannot coerce expression to attribute set: " ++ show e)+--+-- coerceFun :: Value -> (Value -> Value)+-- coerceFun (FunV f) = f+-- coerceFun e = error ("cannot coerce expression to function: " ++ show e)+--+-- coerceStr :: Value -> String+-- coerceStr (StrV x) = x+-- coerceStr e = error ("cannot coerce expression to string: " ++ show e)+--+-- -- getScopedVar :: [String] -> Eval Value+-- -- getScopedVar [] = fail "invalid empty scoped variable"+-- -- getScopedVar (k:[]) = getEnv k+-- -- getScopedVar (k:ks) = getEnv k >>= \e -> local (union (coerceDict e)) (getScopedVar ks)+--+-- -- evalAttr :: Attr -> Eval Dict+-- -- evalAttr (Inherit (SIdent k) is) = fromList <$> forM is (\i -> (,) i <$> getScopedVar (k++[i]))+-- -- evalAttr (Assign (SIdent []) _) = fail "invalid empty scoped identifier in assignment"+-- -- evalAttr (Assign (SIdent (k:[])) e) = singleton k <$> eval e+-- -- evalAttr (Assign (SIdent (k:ks)) e) = (singleton k . AttrSetV) <$> evalAttr (Assign (SIdent ks) e)+--+-- simplifyAttr :: Attr -> Map String Expr+-- simplifyAttr (Inherit (SIdent _) []) = error "invalid empty inherit statement"+-- simplifyAttr (Inherit (SIdent k) is) = unions [ singleton i (foldl1 Deref (map Ident (k++[i]))) | i <- is]+-- simplifyAttr (Assign (SIdent []) _) = error "invalid empty scoped identifier in assignment"+-- simplifyAttr (Assign (SIdent (k:[])) e) = singleton k e+-- simplifyAttr (Assign (SIdent (k:ks)) e) = singleton k (AttrSet False [Assign (SIdent ks) e])+--+-- evalAttr' :: (String, Expr) -> Eval Dict+-- evalAttr' (k, e) = singleton k <$> eval e+--+-- evalDict :: Map String Expr -> Eval Dict+-- evalDict as = unionsWith mergeDicts <$> mapM evalAttr' (assocs as)+--+-- -- -- (Inherit (SIdent k) is) = fromList <$> forM is (\i -> (,) i <$> getScopedVar (k++[i]))+-- -- evalAttr' (Assign (SIdent []) _) = fail "invalid empty scoped identifier in assignment"+-- -- evalAttr' (Assign (SIdent (k:[])) e) = singleton k <$> eval e+-- -- evalAttr' (Assign (SIdent (k:ks)) e) = (singleton k . AttrSetV) <$> evalAttr (Assign (SIdent ks) e)+--+-- eval :: Expr -> Eval Value+-- eval e | trace ("eval: " ++ show e) False = undefined+-- eval (Lit v) = return (StrV v)+-- eval (Ident v) = getEnv v+-- eval (AttrSet False as) = AttrSetV . unionsWith mergeDicts <$> mapM (evalDict . simplifyAttr) as+--+-- eval (AttrSet True as) = do+-- env <- ask+-- let e :: Map String Expr+-- e = unionsWith mergeAttrSets (map simplifyAttr as)+-- return (AttrSetV (resolve env e))+--+-- -- mdo { r@(AttrSetV d) <- local (`union` d) (eval (AttrSet False as)); return r }+--+-- -- eval (AttrSet False as) = AttrSetV . unionsWith mergeDicts <$> mapM evalAttr as+-- -- eval (AttrSet True as) = mdo { r@(AttrSetV d) <- local (`union` d) (eval (AttrSet False as)); return r }+-- eval (Fun (Ident x) y) = do { env <- ask; return (FunV (\v -> runEval' (eval y) (insert x v env))) }+-- eval (Apply x y) = coerceFun <$> eval x <*> eval y+-- eval (Append x y) = StrV <$> ((++) <$> (coerceStr <$> eval x) <*> (coerceStr <$> eval y))+-- eval (Deref x (Ident y)) = coerceDict <$> eval x >>= \x' -> local (const x') (getEnv y)+-- -- default catch-all to report the un-expected expression+-- eval e = fail ("unsupported: " ++ show e)+--+-- mergeDicts :: Value -> Value -> Value+-- mergeDicts x y = AttrSetV (unionWith mergeDicts (coerceDict x) (coerceDict y))+--+-- mergeAttrSets :: Expr -> Expr -> Expr+-- mergeAttrSets (AttrSet False x) (AttrSet False y) = AttrSet False (x++y)+-- mergeAttrSets x y = error ("mergeAttrSets: cannot merge expressions " ++ show x ++ " and " ++ show y)++run :: String -> Either Error Expr+run = either (Left . InvalidSyntax) (\e -> runEval (eval e) builtins) . parseNix++runEval :: Eval a -> Env -> Either Error a+runEval = runReader . runErrorT++builtins :: Env+builtins = fromList+ [ ("true", Boolean True)+ , ("false", Boolean False)+ , ("null", Null)+ ]
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ language-nix.cabal view
@@ -0,0 +1,41 @@+name: language-nix+version: 1.0+synopsis: Haskell AST and Parsers for the Nix language+description: This library provides parsec combinators that parse Nix into an AST.+homepage: https://github.com/peti/language-nix+license: BSD3+license-file: LICENSE+author: Peter Simons <simons@cryp.to>+maintainer: Peter Simons <simons@cryp.to>+category: Language+build-type: Simple+cabal-version: >= 1.8++Source-Repository head+ Type: git+ Location: git://github.com/peti/language-nix.git++Library+ Exposed-Modules: Language.Nix+ Build-Depends: base >= 3 && < 5, parsec, transformers, QuickCheck,+ containers >= 0.4.2, mtl+ Ghc-Options: -Wall++Executable parse-nix+ main-is: parse-nix.hs+ Build-Depends: base, language-nix, parsec, transformers, QuickCheck,+ containers >= 0.4.2, mtl+ Ghc-Options: -Wall++Executable run-nix+ main-is: run-nix.hs+ Build-Depends: base, language-nix, parsec, transformers, QuickCheck,+ containers >= 0.4.2, mtl+ Ghc-Options: -Wall++Test-Suite self-test+ type: exitcode-stdio-1.0+ main-is: self-test.hs+ build-depends: base, language-nix, parsec, transformers,+ containers >= 0.4.2, mtl, doctest, QuickCheck, hspec, HUnit+ Ghc-Options: -Wall
+ parse-nix.hs view
@@ -0,0 +1,16 @@+-- parse-nix.hs++module Main ( main ) where++import Prelude ( fmap, either )+import Language.Nix ( parseNixFile, parseNix )+import System.Environment ( getArgs )+import System.IO ( IO, getContents, hPrint, print, stderr )+import Control.Monad ( mapM_, (>>=), (>=>) )++main :: IO ()+main = do+ args <- getArgs+ case args of+ [] -> fmap parseNix getContents >>= either (hPrint stderr) print+ _ -> mapM_ (parseNixFile >=> either (hPrint stderr) print) args
+ run-nix.hs view
@@ -0,0 +1,16 @@+-- run-nix.hs++module Main ( main ) where++import Prelude ( fmap, either, (.) )+import Language.Nix ( run )+import System.Environment ( getArgs )+import System.IO ( IO, getContents, hPrint, print, stderr, readFile )+import Control.Monad ( mapM_, (>>=), (>=>) )++main :: IO ()+main = do+ args <- getArgs+ case args of+ [] -> fmap run getContents >>= either (hPrint stderr) print+ _ -> mapM_ (readFile >=> (either (hPrint stderr) print) . run) args
+ self-test.hs view
@@ -0,0 +1,187 @@+-- self-test.hs++module Main ( main ) where++import Language.Nix+import qualified Text.Parsec.Token as Parsec ( reservedNames )+import Test.DocTest+import Test.QuickCheck+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.HUnit.Base ( assertFailure, assertEqual )++gives :: (Show err, Eq a, Show a) => Either err a -> a -> Expectation+gives x y = either (assertFailure . msg) (assertEqual "" y) x+ where msg z = "expected: " ++ show y ++ "\nbut got parser error: " ++ show z++parseFail :: Show a => NixParser a -> String -> Expectation+parseFail p input = parse p input `shouldSatisfy` either (const True) (const False)++main :: IO ()+main = do+ doctest [ "Language/Nix.hs" ]+ hspec $ do+ describe "identifier" $ do+ it "parses hand-picked sample inputs" $ do+ parse identifier "abc" `gives` Ident "abc"+ parse identifier "abc " `gives` Ident "abc"+ parse identifier "__a-b-c-__ " `gives` Ident "__a-b-c-__"+ prop "parses all randomly generated samples" $+ forAll genIdentifier $ \input -> either (const False) (Ident input ==) (parse identifier input)+ it "does not swallow leading whitespace" $+ parseFail identifier " abc"+ it "does not parse a de-referencing expression" $+ parseFail identifier "abc.def"+ it "does not accept reserved words" $+ mapM_ (parseFail identifier) (Parsec.reservedNames nixLanguage)+ it "accepts identifiers that are a prefix of a reserved word" $+ parse identifier "lett" `gives` Ident "lett"++ describe "scopedIdentifier" $ do+ it "parses hand-picked sample inputs" $ do+ parse scopedIdentifier "abc" `gives` SIdent ["abc"]+ parse scopedIdentifier "abc " `gives` SIdent ["abc"]+ parse scopedIdentifier "abc.def" `gives` SIdent ["abc","def"]+ -- Need to implement pretty-printing again before this test can be used.+ -- prop "parses all randomly generated samples" $+ -- \sident -> either (const False) (sident ==) (parse scopedIdentifier (show (pretty sident)))+ it "does not swallow leading whitespace" $+ parseFail scopedIdentifier " abc"+ it "does not accept reserved words" $+ mapM_ (parseFail scopedIdentifier) (Parsec.reservedNames nixLanguage)+ it "accepts identifiers that are a prefix of a reserved word" $+ parse scopedIdentifier "lett" `gives` SIdent ["lett"]++ describe "literal" $ do+ -- This is not really true: "\n" gives "\\n", not a LF.+ -- prop "parses all randomly generated literal strings" $+ -- \str -> either (const False) (Lit str ==) (parse literal (show str))+ prop "parses all randomly generated integers" $+ \n -> either (const False) (Lit (show (abs (n::Int))) ==) (parse literal (show (abs n)))+ it "parses paths" $+ parse literal "claus/ist/der/beste" `gives` Lit "claus/ist/der/beste"+ it "parses URIs" $+ parse literal "http://example.org" `gives` Lit "http://example.org"+ it "parses antiquotation" $ do+ -- The literal parser is more or less useless for actually processing+ -- the strings.+ parse literal "''abc''${''" `gives` Lit "abc${"+ parse literal "\"a${b}c\"" `gives` Lit "ac"+ parse literal "\"a${if !x then \"b\" else \"c\"}d\"" `gives` Lit "ad"+ parse literal "''a${if b then \"c\" else ''d''}e''" `gives` Lit "ae"++ describe "attrSet" $ do+ it "parses an empty attribute set" $ do+ parse attrSet "{}" `gives` AttrSet False []+ parse attrSet "rec {}" `gives` AttrSet True []+ it "parses hand-picked sample inputs" $ do+ parse attrSet "{ a = b; }" `gives` AttrSet False [Assign (SIdent ["a"]) (Ident "b")]+ parse attrSet "{ a = b.c; }" `gives` AttrSet False [Assign (SIdent ["a"]) (Deref (Ident "b") (Ident "c"))]+ parse attrSet "{ a = \"b\"; }" `gives` AttrSet False [Assign (SIdent ["a"]) (Lit "b")]+ it "parses attribute sets as values of attribute sets" $+ parse attrSet "{ a = { b = c; }; }" `gives` AttrSet False [Assign (SIdent ["a"]) (AttrSet False [Assign (SIdent ["b"]) (Ident "c")])]+ it "expects assignments to terminated by a semicolon" $+ parseFail attrSet "{ a = b }"+ it "ignores comments" $+ parse attrSet "{ /* foo */ a = /* bar */ b; # foobar\n }" `gives` AttrSet False [Assign (SIdent ["a"]) (Ident "b")]+ it "parses recursive attribute sets" $+ parse attrSet "rec { a = b; b = a; }" `gives` AttrSet True [Assign (SIdent ["a"]) (Ident "b"), Assign (SIdent ["b"]) (Ident "a")]+ it "parses inherit statements" $ do+ parse attrSet "{ inherit a; }" `gives` AttrSet False [Inherit (SIdent []) ["a"]]+ parse attrSet "{ inherit a; inherit b; }" `gives` AttrSet False [Inherit (SIdent []) ["a"],Inherit (SIdent []) ["b"]]+ parse attrSet "{ inherit a b; }" `gives` AttrSet False [Inherit (SIdent []) ["a","b"]]+ parse attrSet "{ inherit (a) b c d; }" `gives` AttrSet False [Inherit (SIdent ["a"]) ["b","c","d"]];+ -- The parser cannot handle this expample yet.+ -- parse attrSet "{ inherit (import ./foo.nix) a b c; }" `gives` Lit "a"++ describe "list" $ do+ it "parses an empty list" $+ parse list "[]" `gives` List []+ it "parses hand-picked sample inputs" $ do+ parse list "[ a b c ]" `gives` List [Ident "a",Ident "b",Ident "c"]+ parse list "[ \"b\" { a = [\"c\"]; } d ]" `gives` List [Lit "b",AttrSet False [Assign (SIdent ["a"]) (List [Lit "c"])],Ident "d"]+ parse list "[ (a b) c ]" `gives` List [Apply (Ident "a") (Ident "b"),Ident "c"]+ parse list "[ 12 8 a 0 ]" `gives` List [Lit "12", Lit "8", Ident "a", Lit "0"]++ describe "reserved" $ do+ it "parses a specific reserved name" $ do+ parse (reserved "let") "let" `gives` ()+ parse (reserved "in") "in" `gives` ()+ parse (reserved "rec") "rec" `gives` ()+ parseFail (reserved "rec") "let"+ it "recognizes if the keyword is actually just a prefix of the input string" $+ parseFail (reserved "in") "input"++ describe "expr" $ do+ it "parses an empty attribute set" $ do+ parse expr "{}" `gives` AttrSet False []+ parse expr "rec {}" `gives` AttrSet True []+ it "parses an empty list" $+ parse expr "[]" `gives` List []+ it "parses a de-referencing expression" $ do+ parse expr "abc.def" `gives` Deref (Ident "abc") (Ident "def")+ parse expr "a.b.c" `gives` Deref (Deref (Ident "a") (Ident "b")) (Ident "c")+ it "parses recursive attribute sets" $+ parse expr "rec { id = x: x; }" `gives` AttrSet True [Assign (SIdent ["id"]) (Fun (Ident "x") (Ident "x"))]+ it "parses boolean expressions" $ do+ parse expr "true" `gives` Ident "true"+ parse expr "false" `gives` Ident "false"+ parse expr "system == \"linux\"" `gives` Equal (Ident "system") (Lit "linux")+ parse expr "system != \"linux\"" `gives` Inequal (Ident "system") (Lit "linux")+ parse expr "true && true" `gives` And (Ident "true") (Ident "true")+ parse expr "false || false" `gives` Or (Ident "false") (Ident "false")+ parse expr "isLinux || isDarwin" `gives` Or (Ident "isLinux") (Ident "isDarwin")+ parse expr "(isLinux || isDarwin)" `gives` Or (Ident "isLinux") (Ident "isDarwin")+ parse expr "(isLinux) || (isDarwin)" `gives` Or (Ident "isLinux") (Ident "isDarwin")+ parse expr "!(!isLinux) || (isDarwin)" `gives` Or (Not (Not (Ident "isLinux"))) (Ident "isDarwin")+ parse expr "!a && b || c" `gives` Or (And (Not (Ident "a")) (Ident "b")) (Ident "c")+ parse expr "a && b || c" `gives` Or (And (Ident "a") (Ident "b")) (Ident "c")+ parse expr "a || b && c" `gives` Or (Ident "a") (And (Ident "b") (Ident "c"))+ parse expr "(a -> b) -> c" `gives` Implies (Implies (Ident "a") (Ident "b")) (Ident "c")+ it "parses simple lambda expressions" $ do+ parse expr "x: {}" `gives` Fun (Ident "x") (AttrSet False [])+ parse expr "x: y: rec{}" `gives` Fun (Ident "x") (Fun (Ident "y") (AttrSet True []))+ it "parses attribute set patterns" $ do+ parse expr "{}: {}" `gives` Fun (AttrSet False []) (AttrSet False [])+ parse expr "{a ? b, c}: {}" `gives` Fun (AttrSetP Nothing [("a",Just (Ident "b")),("c",Nothing)]) (AttrSet False [])+ parse expr "{ id = x: x; }" `gives` AttrSet False [Assign (SIdent ["id"]) (Fun (Ident "x") (Ident "x"))]+ parse expr "{ a?null, b }: rec {}" `gives` Fun (AttrSetP Nothing [("a",Just (Ident "null")),("b",Nothing)]) (AttrSet True [])+ parse expr "{ a?c.d }: {}" `gives` Fun (AttrSetP Nothing [("a",Just (Deref (Ident "c") (Ident "d")))]) (AttrSet False [])+ parse expr "{ a?c.d, ... }: {}" `gives` Fun (AttrSetP Nothing [("a",Just (Deref (Ident "c") (Ident "d"))),("...",Nothing)]) (AttrSet False [])+ parse expr "e@{ a?c.d, ... }: {}" `gives` Fun (AttrSetP (Just "e") [("a",Just (Deref (Ident "c") (Ident "d"))),("...",Nothing)]) (AttrSet False [])+ it "ignores leading/trailing whitespace" $ do+ parse expr " {}" `gives` AttrSet False []+ parse expr "{} " `gives` AttrSet False []+ parse expr " { } " `gives` AttrSet False []+ it "ignores comments" $+ parse expr "# foo\n/* bar \n */ { /* bla */ }" `gives` AttrSet False []+ it "parses function application" $ do+ parse expr "a b c" `gives` Apply (Apply (Ident "a") (Ident "b")) (Ident "c")+ parse expr "a.b c" `gives` Apply (Deref (Ident "a") (Ident "b")) (Ident "c")+ parse expr "a{b=c.d;}" `gives` Apply (Ident "a") (AttrSet False [Assign (SIdent ["b"]) (Deref (Ident "c") (Ident "d"))])+ it "parses import statements" $ do+ parse expr "(import ../some/function.nix) c" `gives` Apply (Import (Lit "../some/function.nix")) (Ident "c")+ parse expr "let x = import ../some/function.nix; in x" `gives` Let [Assign (SIdent ["x"]) (Import (Lit "../some/function.nix"))] (Ident "x")+ it "parses if-then-else statements" $+ parse expr "if a b then c { inherit d; } else e" `gives` IfThenElse (Apply (Ident "a") (Ident "b")) (Apply (Ident "c") (AttrSet False [Inherit (SIdent []) ["d"]])) (Ident "e")+ it "parses with statements" $+ parse expr "with a; a" `gives` Apply (With (Ident "a")) (Ident "a")++ describe "run" $ do+ it "can evaluate simple data types" $ do+ run "null" `gives` Null+ run "true" `gives` Boolean True+ run "false" `gives` Boolean False+ run "\"null\"" `gives` Lit "null"+ run "123" `gives` Lit "123"+ run "http://example.org" `gives` Lit "http://example.org"+ it "can evaluate hand-picked Nix expressions" $ do+ run "rec { y = \"bar\"; f = x: \"foo\" + x; v = f y; }.v" `gives` Lit "foobar"+ -- run "{ a.a.a=1; a.a.b=2; a.b=3; }" `gives` Lit "foo"+ -- run "{ a.a.a=1; a.a.b=2; a.b=3; }.a.a.a" `gives` Lit "1"+ run "bla or false" `gives` Boolean False+ run "let a = \"foo\"; b = a; f = x: x+\"bar\"; in f b" `gives` Lit "foobar"+ run "let a = { b = \"claus\"; }; b = \"bar\"; in { a = \"foo\"; inherit b; c = a.b; }" `gives` AttrSet False [Assign (SIdent ["a"]) (Lit "foo"),Assign (SIdent ["b"]) (Lit "bar"),Assign (SIdent ["c"]) (Lit "claus")]+ run "let a = { b = \"claus\"; }; b = \"bar\"; in { a = \"foo\"; inherit b; c = a.b; }.c" `gives` Lit "claus"+ run "let b = \"bar\"; in rec { a = \"foo\"; inherit b; c = a + b; }" `gives` AttrSet False [Assign (SIdent ["a"]) (Lit "foo"),Assign (SIdent ["b"]) (Lit "bar"),Assign (SIdent ["c"]) (Lit "foobar")]+ run "let { a = \"foo\"; b = a; f = x: x+\"bar\"; body = f b; }" `gives` Lit "foobar"