diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Peter Simons + +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. diff --git a/Language/Nix.hs b/Language/Nix.hs new file mode 100644 --- /dev/null +++ b/Language/Nix.hs @@ -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) "" + +----- 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) + ] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/language-nix.cabal b/language-nix.cabal new file mode 100644 --- /dev/null +++ b/language-nix.cabal @@ -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 +maintainer: Peter Simons +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 diff --git a/parse-nix.hs b/parse-nix.hs new file mode 100644 --- /dev/null +++ b/parse-nix.hs @@ -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 diff --git a/run-nix.hs b/run-nix.hs new file mode 100644 --- /dev/null +++ b/run-nix.hs @@ -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 diff --git a/self-test.hs b/self-test.hs new file mode 100644 --- /dev/null +++ b/self-test.hs @@ -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"