Add support for more operators

This commit is contained in:
John Wiegley 2014-07-04 16:07:32 -05:00
parent 2468bf6826
commit 072b2e8d51
3 changed files with 34 additions and 23 deletions

View File

@ -28,20 +28,21 @@ nixExpr :: Bool -> Parser NExpr
nixExpr = buildExpressionParser table . nixTerm nixExpr = buildExpressionParser table . nixTerm
where where
table = table =
[ [ prefix "-" NNeg ] [ [ binary "." NAttr AssocNone ]
, [ prefix "~" NNeg ] , [ prefix "-" NNeg ]
, [ prefix "?" NNeg ] -- , [ prefix "~" NSubpath ] -- deprecated
, [ binary "++" NConcat AssocRight ] , [ binary "?" NHasAttr AssocNone ]
, [ binary "*" NMult AssocLeft, binary "/" NDiv AssocLeft ] , [ binary "++" NConcat AssocRight ]
, [ binary "+" NPlus AssocLeft, binary "-" NMinus AssocLeft ] , [ binary "*" NMult AssocLeft, binary "/" NDiv AssocLeft ]
, [ binary "+" NPlus AssocLeft, binary "-" NMinus AssocLeft ]
, [ prefix "!" NNot ] , [ prefix "!" NNot ]
, [ binary "//" NUpdate AssocRight ] , [ binary "//" NUpdate AssocRight ]
, [ binary "<" NLt AssocLeft, binary ">" NGt AssocLeft , [ binary "<" NLt AssocLeft, binary ">" NGt AssocLeft
, binary "<=" NLte AssocLeft, binary ">=" NGte AssocLeft ] , binary "<=" NLte AssocLeft, binary ">=" NGte AssocLeft ]
, [ binary "==" NEq AssocNone, binary "!=" NNEq AssocNone ] , [ binary "==" NEq AssocNone, binary "!=" NNEq AssocNone ]
, [ binary "&&" NAnd AssocLeft ] , [ binary "&&" NAnd AssocLeft ]
, [ binary "||" NOr AssocLeft ] , [ binary "||" NOr AssocLeft ]
, [ binary "->" NImpl AssocNone ] , [ binary "->" NImpl AssocNone ]
] ]
binary name fun = Infix ((\x y -> Fix (NOper (fun x y))) <$ symbol name) binary name fun = Infix ((\x y -> Fix (NOper (fun x y))) <$ symbol name)

View File

@ -23,7 +23,7 @@ lexer = P.makeTokenParser P.LanguageDef
, P.commentLine = "#" , P.commentLine = "#"
, P.nestedComments = True , P.nestedComments = True
, P.identStart = letter <|> char '_' , P.identStart = letter <|> char '_'
, P.identLetter = alphaNum <|> oneOf "_." , P.identLetter = alphaNum <|> oneOf "_"
, P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" , P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
, P.opLetter = oneOf "@" , P.opLetter = oneOf "@"
, P.reservedNames = , P.reservedNames =
@ -91,44 +91,52 @@ reserved = fmap pack . symbol
----------------------------------------------------------- -----------------------------------------------------------
-- White space & symbols -- White space & symbols
----------------------------------------------------------- -----------------------------------------------------------
symbol :: (CharParsing m, Monad m) => String -> m String
symbol name = lexeme (string name) symbol name = lexeme (string name)
lexeme p lexeme :: (CharParsing m, Monad m) => m b -> m b
= do{ x <- p; whiteSpace; return x } lexeme p = do{ x <- p; whiteSpace; return x }
whiteSpace :: (CharParsing m, Monad m) => m ()
whiteSpace = whiteSpace =
skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "") skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
simpleSpace :: CharParsing m => m ()
simpleSpace = skipSome (satisfy isSpace) simpleSpace = skipSome (satisfy isSpace)
oneLineComment :: (CharParsing m, Monad m) => m ()
oneLineComment = oneLineComment =
do{ try (string "#") do{ _ <- try (string "#")
; skipMany (satisfy (/= '\n')) ; skipMany (satisfy (/= '\n'))
; return () ; return ()
} }
multiLineComment :: (CharParsing m, Monad m) => m ()
multiLineComment = multiLineComment =
do { try (string "/*") do { _ <- try (string "/*")
; inComment ; inComment
} }
inComment :: (CharParsing m, Monad m) => m ()
inComment inComment
| True = inCommentMulti | True = inCommentMulti
| otherwise = inCommentSingle | otherwise = inCommentSingle
inCommentMulti :: (CharParsing m, Monad m) => m ()
inCommentMulti inCommentMulti
= do{ try (string "*/") ; return () } = do{ _ <- try (string "*/") ; return () }
<|> do{ multiLineComment ; inCommentMulti } <|> do{ multiLineComment ; inCommentMulti }
<|> do{ skipSome (noneOf startEnd) ; inCommentMulti } <|> do{ skipSome (noneOf startEnd) ; inCommentMulti }
<|> do{ oneOf startEnd ; inCommentMulti } <|> do{ _ <- oneOf startEnd ; inCommentMulti }
<?> "end of comment" <?> "end of comment"
where where
startEnd = nub ("*/" ++ "/*") startEnd = nub ("*/" ++ "/*")
inCommentSingle :: (CharParsing m, Monad m) => m ()
inCommentSingle inCommentSingle
= do{ try (string "*/"); return () } = do{ _ <- try (string "*/"); return () }
<|> do{ skipSome (noneOf startEnd) ; inCommentSingle } <|> do{ skipSome (noneOf startEnd) ; inCommentSingle }
<|> do{ oneOf startEnd ; inCommentSingle } <|> do{ _ <- oneOf startEnd ; inCommentSingle }
<?> "end of comment" <?> "end of comment"
where where
startEnd = nub ("*/" ++ "/*") startEnd = nub ("*/" ++ "/*")

View File

@ -59,6 +59,7 @@ data NOperF r
| NImpl r r | NImpl r r
| NUpdate r r | NUpdate r r
| NHasAttr r r | NHasAttr r r
| NAttr r r
| NPlus r r | NPlus r r
| NMinus r r | NMinus r r
@ -82,6 +83,7 @@ instance Show f => Show (NOperF f) where
show (NImpl r1 r2) = show r1 ++ " -> " ++ show r2 show (NImpl r1 r2) = show r1 ++ " -> " ++ show r2
show (NUpdate r1 r2) = show r1 ++ " // " ++ show r2 show (NUpdate r1 r2) = show r1 ++ " // " ++ show r2
show (NHasAttr r1 r2) = show r1 ++ " ? " ++ show r2 show (NHasAttr r1 r2) = show r1 ++ " ? " ++ show r2
show (NAttr r1 r2) = show r1 ++ "." ++ show r2
show (NPlus r1 r2) = show r1 ++ " + " ++ show r2 show (NPlus r1 r2) = show r1 ++ " + " ++ show r2
show (NMinus r1 r2) = show r1 ++ " - " ++ show r2 show (NMinus r1 r2) = show r1 ++ " - " ++ show r2