picnoir/hnix
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Passing all the basic parser and evaluation tests now

Browse source
This commit is contained in:
John Wiegley 2018-04-09 23:34:21 -07:00
parent 8f37f37986
commit 70f21d30ae
3 changed files with 126 additions and 155 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

127
src/Nix/Parser.hs
View file

@ -34,8 +34,8 @@ nixExprLoc :: Parser NExprLoc
nixExprLoc = whiteSpace *> (nixToplevelForm <|> exprParser)
exprParser :: Parser NExprLoc
exprParser = makeExprParser (nixTerm <* whiteSpace) $
map (map snd) (nixOperators (nixTerm <* whiteSpace) nixSelector selDot)
exprParser = makeExprParser (try nixTerm) $
map (map snd) (nixOperators nixSelector)
antiStart :: Parser Text
antiStart = try (symbol "${") <?> show ("${" :: String)
@ -44,38 +44,74 @@ nixAntiquoted :: Parser a -> Parser (Antiquoted a NExprLoc)
nixAntiquoted p =
Antiquoted <$> (antiStart *> nixExprLoc <* symbol "}")
<|> Plain <$> p
<?> "anti-quotation"
selDot :: Parser ()
selDot = try (char '.' *> notFollowedBy (("path" :: String) <$ nixPath))
*> whiteSpace
<?> "."
selDot = try (symbol "." *> notFollowedBy nixPath) <?> "."
nixSelect :: Parser NExprLoc -> Parser NExprLoc
nixSelect term = build
<$> term
<*> optional ((,) <$> (selDot *> nixSelector)
<*> optional (reserved "or" *> nixTerm))
where
build :: NExprLoc
-> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc)
-> NExprLoc
build t Nothing = t
build t (Just (s,o)) = nSelectLoc t s o
nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc))
nixSelector = annotateLocation $ keyName `sepBy1` selDot
{-
-- | A self-contained unit.
nixTerm :: Parser NExprLoc
nixTerm = choice
[ {-dbg "Path" -} nixPath
, {-dbg "SPath" -} nixSPath
, {-dbg "Float" -} nixFloat
, {-dbg "Int" -} nixInt
, {-dbg "Bool" $ -} try (nixBool <* notFollowedBy (char '-'))
, {-dbg "Null" $ -} try (nixNull <* notFollowedBy (char '-'))
, {-dbg "Parens" -} nixParens
, {-dbg "List" -} nixList
, {-dbg "Uri" -} nixUri
, {-dbg "StringExpr" -} nixStringExpr
, {-dbg "Set" -} nixSet
, {-dbg "Path" -} nixSym ]
[ dbg "Path" nixPath
, dbg "SPath" nixSPath
, dbg "Float" nixFloat
, dbg "Int" nixInt
, dbg "Bool" nixBool
, dbg "Null" nixNull
, dbg "Parens" nixParens
, dbg "List" nixList
, dbg "Uri" nixUri
, dbg "StringExpr" nixStringExpr
, dbg "Set" nixSet
, dbg "Sym" nixSym ]
nixToplevelForm :: Parser NExprLoc
nixToplevelForm = choice
[ {-dbg "Lambda" -} nixLambda
, {-dbg "Let" -} nixLet
, {-dbg "If" -} nixIf
, {-dbg "Assert" -} nixAssert
, {-dbg "Lambda" -} nixWith ]
[ dbg "Lambda" nixLambda
, dbg "Let" nixLet
, dbg "If" nixIf
, dbg "Assert" nixAssert
, dbg "Lambda" nixWith ]
-}
nixTerm :: Parser NExprLoc
nixTerm = nixSelect $ choice
[ nixPath
, nixSPath
, nixFloat
, nixInt
, nixBool
, nixNull
, nixParens
, nixList
, nixUri
, nixStringExpr
, nixSet
, nixSym ]
nixToplevelForm :: Parser NExprLoc
nixToplevelForm = choice
[ nixLambda
, nixLet
, nixIf
, nixAssert
, nixWith ]
nixSym :: Parser NExprLoc
nixSym = annotateLocation1 $ mkSymF <$> identifier
@ -87,12 +123,14 @@ nixFloat :: Parser NExprLoc
nixFloat = annotateLocation1 (try (mkFloatF . realToFrac <$> float) <?> "float")
nixBool :: Parser NExprLoc
nixBool = annotateLocation1 (try (true <|> false) <?> "bool") where
true = mkBoolF True <$ reserved "true"
false = mkBoolF False <$ reserved "false"
nixBool = annotateLocation1 (try (bool "true" True <|>
bool "false" False) <?> "bool") where
bool str b = mkBoolF b <$ lexeme (string str <* notFollowedBy pathChar)
nixNull :: Parser NExprLoc
nixNull = annotateLocation1 (mkNullF <$ try (reserved "null") <?> "null")
nixNull = annotateLocation1
(mkNullF <$ try (lexeme (string "null" <* notFollowedBy pathChar))
<?> "null")
nixParens :: Parser NExprLoc
nixParens = parens nixExprLoc <?> "parens"
@ -100,10 +138,9 @@ nixParens = parens nixExprLoc <?> "parens"
nixList :: Parser NExprLoc
nixList = annotateLocation1 (brackets (NList <$> many nixTerm) <?> "list")
pathChar :: Bool -> Parser Char
pathChar allowSlash = satisfy $ \x ->
pathChar :: Parser Char
pathChar = satisfy $ \x ->
isAlpha x || isDigit x || x == '.' || x == '_' || x == '-' || x == '+'
|| (allowSlash && x == '/')
slash :: Parser Char
slash = try (char '/' <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x)))
@ -113,26 +150,24 @@ slash = try (char '/' <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || i
-- looked up in the NIX_PATH environment variable at evaluation.
nixSPath :: Parser NExprLoc
nixSPath = annotateLocation1
(mkPathF True <$> try (char '<' *> some (pathChar True) <* symbol ">")
(mkPathF True <$> try (char '<' *> many (pathChar <|> slash) <* symbol ">")
<?> "spath")
pathStr :: Parser FilePath
pathStr = liftM2 (++) (many pathChar)
(Prelude.concat <$> some (liftM2 (:) slash (some pathChar)))
nixPath :: Parser NExprLoc
nixPath = annotateLocation1 $ try $ do
start <- many (pathChar False)
middle <- some slash
finish <- some (pathChar True)
whiteSpace
return $ mkPathF False $ start ++ middle ++ finish
nixPath = annotateLocation1 $ try $ mkPathF False <$> pathStr
nixLet :: Parser NExprLoc
nixLet = annotateLocation1 (reserved "let"
*> whiteSpace
*> (letBody <|> letBinders)
<?> "let block")
where
letBinders = NLet
<$> nixBinders
<*> (whiteSpace *> reserved "in" *> nixExprLoc)
<*> (reserved "in" *> nixExprLoc)
-- Let expressions `let {..., body = ...}' are just desugared
-- into `(rec {..., body = ...}).body'.
letBody = (\x pos -> NSelect x [StaticKey "body" (Just pos)] Nothing)
@ -142,8 +177,8 @@ nixLet = annotateLocation1 (reserved "let"
nixIf :: Parser NExprLoc
nixIf = annotateLocation1 (NIf
<$> (reserved "if" *> nixExprLoc)
<*> (whiteSpace *> reserved "then" *> nixExprLoc)
<*> (whiteSpace *> reserved "else" *> nixExprLoc)
<*> (reserved "then" *> nixExprLoc)
<*> (reserved "else" *> nixExprLoc)
<?> "if")
nixAssert :: Parser NExprLoc
@ -170,16 +205,15 @@ uriAfterColonC = alphaNumChar <|>
satisfy (\x -> x `elem` ("%/?:@&=+$,-_.!~*'" :: String))
nixUri :: Parser NExprLoc
nixUri = annotateLocation1 $ parseToken $ fmap (mkUriF . pack) $ (++)
nixUri = annotateLocation1 $ fmap (mkUriF . pack) $ (++)
<$> try ((++) <$> (scheme <* char ':') <*> fmap (\x -> [':',x]) uriAfterColonC)
<*> many uriAfterColonC
where
scheme = (:) <$> letterChar
<*> many (alphaNumChar <|> satisfy (\x -> x `elem` ("+-." :: String)))
parseToken p = p <* whiteSpace
nixString :: Parser (NString NExprLoc)
nixString = doubleQuoted <|> indented <?> "string"
nixString = lexeme (doubleQuoted <|> indented <?> "string")
where
doubleQuoted :: Parser (NString NExprLoc)
doubleQuoted = DoubleQuoted . removePlainEmpty . mergePlain
@ -187,7 +221,7 @@ nixString = doubleQuoted <|> indented <?> "string"
<* doubleQ)
<?> "double quoted string"
doubleQ = void $ char '"'
doubleQ = void (char '"')
doubleEscape = Plain . singleton <$> (char '\\' *> escapeCode)
indented :: Parser (NString NExprLoc)
@ -252,8 +286,7 @@ argExpr = choice [atLeft, onlyname, atRight] <* symbol ":" where
-- Could be nothing, in which just return what we have so far.
option (acc, False) $ do
-- Get an argument name and an optional default.
pair <- liftA2 (,) (identifier <* whiteSpace)
(optional $ question *> nixExprLoc)
pair <- liftA2 (,) identifier (optional $ question *> nixExprLoc)
-- Either return this, or attempt to get a comma and restart.
option (acc ++ [pair], False) $ comma >> go (acc ++ [pair])
@ -268,7 +301,7 @@ nixBinders = (inherit <|> namedVar) `endBy` semi where
scope = parens nixExprLoc <?> "inherit scope"
keyName :: Parser (NKeyName NExprLoc)
keyName = (dynamicKey <|> staticKey) <* whiteSpace where
keyName = (dynamicKey <|> staticKey) where
staticKey = do
beg <- getPosition
StaticKey <$> identifier <*> pure (Just beg)

110
src/Nix/Parser/Library.hs
View file

@ -23,84 +23,30 @@ import Text.Megaparsec.Char as X
import qualified Text.Megaparsec.Char.Lexer as L
import Text.PrettyPrint.ANSI.Leijen as X (Doc, text)
{-
instance TokenParsing p => TokenParsing (NixParser p) where
someSpace = NixParser $ buildSomeSpaceParser' someSpace commentStyle
nesting = NixParser . nesting . runNixParser
highlight h = NixParser . highlight h . runNixParser
semi = token $ char ';' <?> ";"
token p = p <* whiteSpace
buildSomeSpaceParser' :: forall m. CharParsing m => m () -> CommentStyle -> m ()
buildSomeSpaceParser' simpleSpace
(CommentStyle startStyle endStyle lineStyle nestingStyle)
| noLine && noMulti = skipSome (simpleSpace <?> "")
| noLine = skipSome (simpleSpace <|> multiLineComment <?> "")
| noMulti = skipSome (simpleSpace <|> oneLineComment <?> "")
| otherwise =
skipSome (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
whiteSpace :: Parser ()
whiteSpace = L.space space1 lineCmnt blockCmnt
where
noLine = Prelude.null lineStyle
noMulti = Prelude.null startStyle
lineCmnt = L.skipLineComment "#"
blockCmnt = L.skipBlockComment "/*" "*/"
oneLineComment, multiLineComment, inComment, inCommentMulti :: m ()
oneLineComment = try (string lineStyle) *> skipMany (satisfy (\x -> x `notElem` ['\r', '\n']))
multiLineComment = try (string startStyle) *> inComment
inComment = if nestingStyle then inCommentMulti else inCommentSingle
inCommentMulti
= () <$ try (string endStyle)
<|> multiLineComment *> inCommentMulti
<|> skipSome (noneOf startEnd) *> inCommentMulti
<|> oneOf startEnd *> inCommentMulti
<?> "end of comment"
lexeme :: Parser a -> Parser a
lexeme p = p <* whiteSpace
{-# INLINEABLE lexeme #-}
startEnd = nub (endStyle ++ startStyle)
symbol = lexeme . string
reservedOp = symbol
reserved = symbol
inCommentSingle :: m ()
inCommentSingle
= () <$ try (string endStyle)
<|> skipSome (noneOf startEnd) *> inCommentSingle
<|> oneOf startEnd *> inCommentSingle
<?> "end of comment"
-}
opStart :: Parser Char
opStart = satisfy $ \x ->
-- jww (2018-04-09): Could this be faster?
x `elem` (".+-*/=<>&|!?" :: String)
{-
commentStyle :: CommentStyle
commentStyle = CommentStyle
{ _commentStart = "/*"
, _commentEnd = "*/"
, _commentLine = "#"
, _commentNesting = False
}
identStyle :: CharParsing m => IdentifierStyle m
identStyle = IdentifierStyle
{ _styleName = "identifier"
, _styleStart = identStart
, _styleLetter = identLetter
, _styleReserved = reservedNames
, _styleHighlight = Identifier
, _styleReservedHighlight = ReservedIdentifier
}
identifier :: (TokenParsing m, Monad m) => m Text
identifier = ident identStyle <?> "identifier"
reserved :: (TokenParsing m, Monad m) => String -> m ()
reserved = reserve identStyle
reservedOp :: TokenParsing m => String -> m ()
reservedOp o = token $ try $ void $
highlight ReservedOperator (string o)
<* (notFollowedBy opLetter <?> "end of " ++ o)
opLetter :: CharParsing m => m Char
opLetter = oneOf ">+/&|="
-}
opStart :: Parser Char
opStart = satisfy $ \x -> x `elem` (".+-*/=<>&|!?" :: String)
identStart :: Parser Char
identStart = letterChar <|> char '_'
@ -108,11 +54,10 @@ identLetter :: Parser Char
identLetter = satisfy $ \x ->
isAlpha x || isDigit x || x == '"' || x == '_' || x == '\'' || x == '-'
symbol = L.symbol whiteSpace
lexeme = L.lexeme whiteSpace
reservedOp = symbol
identifier = pack <$> ((:) <$> identStart <*> many identLetter)
reserved = symbol
identifier = lexeme $ try $ do
ident <- pack <$> ((:) <$> identStart <*> many identLetter)
guard (not (ident `HashSet.member` reservedNames))
return ident
parens = between (symbol "(") (symbol ")")
braces = between (symbol "{") (symbol "}")
@ -131,9 +76,6 @@ integer = lexeme L.decimal
float :: Parser Double
float = lexeme L.float
-- number :: Parser Scientific
-- number = lexeme L.scientific -- similar to ‘naturalOrFloat’ in Parsec
reservedNames :: HashSet Text
reservedNames = HashSet.fromList
[ "let", "in"
@ -142,21 +84,7 @@ reservedNames = HashSet.fromList
, "with"
, "rec"
, "inherit"
, "true"
, "false"
]
{-
stopWords :: (TokenParsing m, Monad m) => m ()
stopWords = () <$
(whiteSpace *> (reserved "in" <|> reserved "then" <|> reserved "else"))
-}
whiteSpace :: Parser ()
whiteSpace = L.space space1 lineCmnt blockCmnt
where
lineCmnt = L.skipLineComment "#"
blockCmnt = L.skipBlockComment "/*" "*/"
, "true", "false" ]
type Parser = ParsecT Void Text Identity

44
src/Nix/Parser/Operators.hs
View file

@ -41,11 +41,14 @@ annotateLocation p = do
annotateLocation1 :: Parser (NExprF NExprLoc) -> Parser NExprLoc
annotateLocation1 = fmap annToAnnF . annotateLocation
operator n = (lexeme . try) (string n <* notFollowedBy opStart)
manyUnaryOp f = foldr1 (.) <$> some f
operator "/" = lexeme . try $ string "/" <* notFollowedBy (char '/')
operator n = symbol n
opWithLoc :: Text -> o -> (Ann SrcSpan o -> a) -> Parser a
opWithLoc name op f = do
Ann ann _ <- annotateLocation (whiteSpace *> operator name)
Ann ann _ <- annotateLocation $ operator name
return $ f (Ann ann op)
binaryN name op = (NBinaryDef name op NAssocNone,
@ -54,21 +57,28 @@ binaryL name op = (NBinaryDef name op NAssocLeft,
InfixL (opWithLoc name op nBinary))
binaryR name op = (NBinaryDef name op NAssocRight,
InfixR (opWithLoc name op nBinary))
prefix name op = (NUnaryDef name op, Prefix (opWithLoc name op nUnary))
postfix name op = (NUnaryDef name op, Postfix (opWithLoc name op nUnary))
prefix name op = (NUnaryDef name op,
Prefix (manyUnaryOp (opWithLoc name op nUnary)))
postfix name op = (NUnaryDef name op,
Postfix (opWithLoc name op nUnary))
nixOperators
:: Parser NExprLoc
-> Parser (Ann SrcSpan (NAttrPath NExprLoc))
-> Parser ()
:: Parser (Ann SrcSpan (NAttrPath NExprLoc))
-> [[(NOperatorDef, Operator Parser NExprLoc)]]
nixOperators term selector seldot =
[ {- 1 -} [ (NSpecialDef "." NSelectOp NAssocLeft,
Postfix $ do
sel <- seldot *> selector
mor <- optional (reserved "or" *> term)
return $ \x -> nSelectLoc x sel mor) ]
, {- 2 -} [ (NBinaryDef " " NApp NAssocLeft,
nixOperators selector =
[ -- This is not parsed here, even though technically it's part of the
-- expression table. The problem is that in same cases, such as list
-- membership, it's also a term. And since terms are effectively the
-- highest precedence entities parsed by the expression parser, it ends up
-- working out that we parse them as a kind of "meta-term".
-- {- 1 -} [ (NSpecialDef "." NSelectOp NAssocLeft,
-- Postfix $ do
-- sel <- seldot *> selector
-- mor <- optional (reserved "or" *> term)
-- return $ \x -> nSelectLoc x sel mor) ]
{- 2 -} [ (NBinaryDef " " NApp NAssocLeft,
-- Thanks to Brent Yorgey for showing me this trick!
InfixL $ nApp <$ symbol "") ]
, {- 3 -} [ prefix "-" NNeg ]
@ -101,7 +111,7 @@ data OperatorInfo = OperatorInfo
getUnaryOperator :: NUnaryOp -> OperatorInfo
getUnaryOperator = (m Map.!) where
m = Map.fromList $ concat $ zipWith buildEntry [1..]
(nixOperators (error "unused") (error "unused") (error "unused"))
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case
(NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)]
_ -> []
@ -109,7 +119,7 @@ getUnaryOperator = (m Map.!) where
getBinaryOperator :: NBinaryOp -> OperatorInfo
getBinaryOperator = (m Map.!) where
m = Map.fromList $ concat $ zipWith buildEntry [1..]
(nixOperators (error "unused") (error "unused") (error "unused"))
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case
(NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)]
_ -> []
@ -117,7 +127,7 @@ getBinaryOperator = (m Map.!) where
getSpecialOperator :: NSpecialOp -> OperatorInfo
getSpecialOperator = (m Map.!) where
m = Map.fromList $ concat $ zipWith buildEntry [1..]
(nixOperators (error "unused") (error "unused") (error "unused"))
(nixOperators (error "unused"))
buildEntry i = concatMap $ \case
(NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)]
_ -> []