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
where
table =
[ [ prefix "-" NNeg ]
, [ prefix "~" NNeg ]
, [ prefix "?" NNeg ]
, [ binary "++" NConcat AssocRight ]
, [ binary "*" NMult AssocLeft, binary "/" NDiv AssocLeft ]
, [ binary "+" NPlus AssocLeft, binary "-" NMinus AssocLeft ]
[ [ binary "." NAttr AssocNone ]
, [ prefix "-" NNeg ]
-- , [ prefix "~" NSubpath ] -- deprecated
, [ binary "?" NHasAttr AssocNone ]
, [ binary "++" NConcat AssocRight ]
, [ binary "*" NMult AssocLeft, binary "/" NDiv AssocLeft ]
, [ binary "+" NPlus AssocLeft, binary "-" NMinus AssocLeft ]
, [ prefix "!" NNot ]
, [ binary "//" NUpdate AssocRight ]
, [ binary "<" NLt AssocLeft, binary ">" NGt AssocLeft
, binary "<=" NLte AssocLeft, binary ">=" NGte AssocLeft ]
, [ binary "==" NEq AssocNone, binary "!=" NNEq AssocNone ]
, [ binary "&&" NAnd AssocLeft ]
, [ binary "||" NOr AssocLeft ]
, [ binary "->" NImpl AssocNone ]
, [ binary "//" NUpdate AssocRight ]
, [ binary "<" NLt AssocLeft, binary ">" NGt AssocLeft
, binary "<=" NLte AssocLeft, binary ">=" NGte AssocLeft ]
, [ binary "==" NEq AssocNone, binary "!=" NNEq AssocNone ]
, [ binary "&&" NAnd AssocLeft ]
, [ binary "||" NOr AssocLeft ]
, [ binary "->" NImpl AssocNone ]
]
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.nestedComments = True
, P.identStart = letter <|> char '_'
, P.identLetter = alphaNum <|> oneOf "_."
, P.identLetter = alphaNum <|> oneOf "_"
, P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
, P.opLetter = oneOf "@"
, P.reservedNames =
@ -91,44 +91,52 @@ reserved = fmap pack . symbol
-----------------------------------------------------------
-- White space & symbols
-----------------------------------------------------------
symbol :: (CharParsing m, Monad m) => String -> m String
symbol name = lexeme (string name)
lexeme p
= do{ x <- p; whiteSpace; return x }
lexeme :: (CharParsing m, Monad m) => m b -> m b
lexeme p = do{ x <- p; whiteSpace; return x }
whiteSpace :: (CharParsing m, Monad m) => m ()
whiteSpace =
skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
simpleSpace :: CharParsing m => m ()
simpleSpace = skipSome (satisfy isSpace)
oneLineComment :: (CharParsing m, Monad m) => m ()
oneLineComment =
do{ try (string "#")
do{ _ <- try (string "#")
; skipMany (satisfy (/= '\n'))
; return ()
}
multiLineComment :: (CharParsing m, Monad m) => m ()
multiLineComment =
do { try (string "/*")
do { _ <- try (string "/*")
; inComment
}
inComment :: (CharParsing m, Monad m) => m ()
inComment
| True = inCommentMulti
| otherwise = inCommentSingle
inCommentMulti :: (CharParsing m, Monad m) => m ()
inCommentMulti
= do{ try (string "*/") ; return () }
<|> do{ multiLineComment ; inCommentMulti }
= do{ _ <- try (string "*/") ; return () }
<|> do{ multiLineComment ; inCommentMulti }
<|> do{ skipSome (noneOf startEnd) ; inCommentMulti }
<|> do{ oneOf startEnd ; inCommentMulti }
<|> do{ _ <- oneOf startEnd ; inCommentMulti }
<?> "end of comment"
where
startEnd = nub ("*/" ++ "/*")
inCommentSingle :: (CharParsing m, Monad m) => m ()
inCommentSingle
= do{ try (string "*/"); return () }
= do{ _ <- try (string "*/"); return () }
<|> do{ skipSome (noneOf startEnd) ; inCommentSingle }
<|> do{ oneOf startEnd ; inCommentSingle }
<|> do{ _ <- oneOf startEnd ; inCommentSingle }
<?> "end of comment"
where
startEnd = nub ("*/" ++ "/*")

View File

@ -59,6 +59,7 @@ data NOperF r
| NImpl r r
| NUpdate r r
| NHasAttr r r
| NAttr r r
| NPlus 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 (NUpdate 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 (NMinus r1 r2) = show r1 ++ " - " ++ show r2