Permalink
Browse files

fix #2

  • Loading branch information...
osa1 committed Jan 20, 2015
1 parent 2a12c81 commit b4bebe36e927dcc671dbe6dd19572b83073dc556
Showing with 103 additions and 62 deletions.
  1. +57 −42 src/Language/Lua/Annotated/Parser.hs
  2. +23 −20 src/Language/Lua/PrettyPrinter.hs
  3. +23 −0 tests/Main.hs
@@ -1,6 +1,8 @@
{-# OPTIONS_GHC -fno-warn-hi-shadowing
-fno-warn-name-shadowing
-fno-warn-unused-do-bind #-}
+{-# LANGUAGE LambdaCase, TupleSections #-}
+
module Language.Lua.Annotated.Parser
( parseText
, parseFile
@@ -17,10 +19,8 @@ import Language.Lua.Token
import Text.Parsec hiding (string)
import Text.Parsec.LTok
-import Text.Parsec.Expr
import Control.Applicative ((<*), (<$>), (<*>))
import Control.Monad (liftM)
-import Data.List (foldl1')
-- | Runs Lua lexer before parsing. Use @parseText stat@ to parse
-- statements, and @parseText exp@ to parse expressions.
@@ -195,7 +195,7 @@ table = do
---- Expressions
nilExp, boolExp, numberExp, stringExp, varargExp, fundefExp,
- prefixexpExp, tableconstExp, exp, exp' :: Parser (Exp SourcePos)
+ prefixexpExp, tableconstExp, exp :: Parser (Exp SourcePos)
nilExp = (Nil <$> getPosition) <* tok LTokNil
@@ -220,47 +220,62 @@ prefixexpExp = PrefixExp <$> getPosition <*> liftM sexpToPexp suffixedExp
tableconstExp = TableConst <$> getPosition <*> table
-binary :: Monad m => LToken -> (SourcePos -> a -> a -> a) -> Assoc -> Operator [LTok] u m a
-binary op fun = Infix (do pos <- getPosition; tok op; return $ fun pos)
-
-prefix :: Monad m => LToken -> (SourcePos -> a -> a) -> Operator [LTok] u m a
-prefix op fun = Prefix $ do
- opPos <- many1 (getPosition <* tok op)
- return $ foldl1' (.) $ map fun opPos
-
-opTable :: Monad m => SourcePos -> [[Operator [LTok] u m (Exp SourcePos)]]
-opTable pos = [ [ binary LTokExp (Binop pos . Exp) AssocRight ]
- , [ prefix LTokNot (Unop pos . Not)
- , prefix LTokSh (Unop pos . Len)
- , prefix LTokMinus (Unop pos . Neg)
- ]
- , [ binary LTokStar (Binop pos . Mul) AssocLeft
- , binary LTokSlash (Binop pos . Div) AssocLeft
- , binary LTokPercent (Binop pos . Mod) AssocLeft
- ]
- , [ binary LTokPlus (Binop pos . Add) AssocLeft
- , binary LTokMinus (Binop pos . Sub) AssocLeft
- ]
- , [ binary LTokDDot (Binop pos . Concat) AssocRight ]
- , [ binary LTokGT (Binop pos . GT) AssocLeft
- , binary LTokLT (Binop pos . LT) AssocLeft
- , binary LTokGEq (Binop pos . GTE) AssocLeft
- , binary LTokLEq (Binop pos . LTE) AssocLeft
- , binary LTokNotequal (Binop pos . NEQ) AssocLeft
- , binary LTokEqual (Binop pos . EQ) AssocLeft
- ]
- , [ binary LTokAnd (Binop pos . And) AssocLeft ]
- , [ binary LTokOr (Binop pos . Or) AssocLeft ]
- ]
-opExp :: SourcePos -> Parser (Exp SourcePos)
-opExp pos = buildExpressionParser (opTable pos) exp' <?> "opExp"
-
-exp' = choice [ nilExp, boolExp, numberExp, stringExp, varargExp,
- fundefExp, prefixexpExp, tableconstExp ]
+type Binop' = Exp SourcePos -> Exp SourcePos -> Exp SourcePos
+type Unop' = Exp SourcePos -> Exp SourcePos
+
+binop :: Parser (Binop', Int, Int)
+binop = do
+ pos <- getPosition
+ choice
+ [ tok LTokPlus >> return (Binop pos (Add pos), 10, 10)
+ , tok LTokMinus >> return (Binop pos (Sub pos), 10, 10)
+ , tok LTokStar >> return (Binop pos (Mul pos), 11, 11)
+ , tok LTokSlash >> return (Binop pos (Div pos), 11, 11)
+ , tok LTokExp >> return (Binop pos (Exp pos), 14, 13)
+ , tok LTokPercent >> return (Binop pos (Mod pos), 11, 11)
+ , tok LTokDDot >> return (Binop pos (Concat pos), 9, 8)
+ , tok LTokLT >> return (Binop pos (LT pos), 3, 3)
+ , tok LTokLEq >> return (Binop pos (LTE pos), 3, 3)
+ , tok LTokGT >> return (Binop pos (GT pos), 3, 3)
+ , tok LTokGEq >> return (Binop pos (GTE pos), 3, 3)
+ , tok LTokEqual >> return (Binop pos (EQ pos), 3, 3)
+ , tok LTokNotequal >> return (Binop pos (NEQ pos), 3, 3)
+ , tok LTokAnd >> return (Binop pos (And pos), 2, 2)
+ , tok LTokOr >> return (Binop pos (Or pos), 1, 1)
+ ]
+
+unop :: Parser (Unop', Int)
+unop = do
+ pos <- getPosition
+ unopTok <- choice
+ [ tok LTokMinus >> return Neg
+ , tok LTokNot >> return Not
+ , tok LTokSh >> return Len
+ ]
+ return (Unop pos (unopTok pos), 12)
+
+subexp :: Int -> Parser (Exp SourcePos, Maybe (Binop', Int, Int))
+subexp limit = do
+ (e1, bop) <- optionMaybe unop >>=
+ \case Nothing -> (, Nothing) <$> simpleExp
+ Just (uop, uopPri) -> do
+ (e1, bop) <- subexp uopPri
+ return (uop e1, bop)
+ maybe (optionMaybe binop) (return . Just) bop >>= loop limit e1
+ where
+ loop _ e1 Nothing = return (e1, Nothing)
+ loop limit e1 (Just b@(bop, bopPriL, bopPriR))
+ | bopPriL > limit = do
+ (e2, nextOp) <- subexp bopPriR
+ loop limit (bop e1 e2) nextOp
+ | otherwise = return (e1, Just b)
+
+simpleExp :: Parser (Exp SourcePos)
+simpleExp = choice [ nilExp, boolExp, numberExp, stringExp, varargExp,
+ fundefExp, prefixexpExp, tableconstExp ]
-- | Expression parser.
-exp = choice [ opExp =<< getPosition, nilExp, boolExp, numberExp, stringExp, varargExp,
- fundefExp, prefixexpExp, tableconstExp ]
+exp = fst <$> subexp 0
-----------------------------------------------------------------------
---- Statements
@@ -50,10 +50,13 @@ instance LPretty Exp where
pprint' _ (EFunDef f) = pprint f
pprint' _ (PrefixExp pe) = pprint pe
pprint' _ (TableConst t) = pprint t
- pprint' p (Binop op e1 e2) = ps (pprint' opPrec e1 <+> pprint op <+> pprint' opPrec e2)
+ pprint' p (Binop op e1 e2) = ps (pprint' opPrecL e1 <+> pprint op
+ <+> case e2 of
+ Unop{} -> pprint e2
+ _ -> pprint' opPrecR e2)
where
- opPrec = getBinopPrec op
- ps = if opPrec < p then parens else id
+ (opPrecL, opPrecR) = getBinopPrec op
+ ps = if min opPrecL opPrecR < p then parens else id
pprint' p (Unop op e) = ps (pprint op <> pprint' opPrec e)
where
opPrec = getUnopPrec op
@@ -86,27 +89,27 @@ instance LPretty Unop where
pprint Not = text "not "
pprint Len = char '#'
-getBinopPrec :: Binop -> Precedence
+getBinopPrec :: Binop -> (Precedence, Precedence)
getBinopPrec op =
case op of
- Add -> 5
- Sub -> 5
- Mul -> 6
- Div -> 6
- Exp -> 8
- Mod -> 6
- Concat -> 4
- LT -> 3
- LTE -> 3
- GT -> 3
- GTE -> 3
- EQ -> 3
- NEQ -> 3
- And -> 2
- Or -> 1
+ Add -> (10, 10)
+ Sub -> (10, 10)
+ Mul -> (11, 11)
+ Div -> (11, 11)
+ Exp -> (14, 13)
+ Mod -> (11, 11)
+ Concat -> (9, 8)
+ LT -> (3, 3)
+ LTE -> (3, 3)
+ GT -> (3, 3)
+ GTE -> (3, 3)
+ EQ -> (3, 3)
+ NEQ -> (3, 3)
+ And -> (2, 2)
+ Or -> (1, 1)
getUnopPrec :: Unop -> Precedence
-getUnopPrec = const 7
+getUnopPrec = const 12
instance LPretty PrefixExp where
pprint (PEVar var) = pprint var
View
@@ -21,6 +21,7 @@ import Test.Tasty.QuickCheck
import Control.Applicative
import Control.Monad (forM_)
+import Data.Char (isSpace)
import GHC.Generics
import Prelude hiding (Ordering (..), exp)
@@ -85,7 +86,29 @@ regressions :: TestTree
regressions = testGroup "Regression tests"
[ testCase "Lexing comment with text \"EOF\" in it" $ do
assertEqual "Lexing is wrong" [(T.LTokEof, L.AlexPn (-1) (-1) (-1))] (L.llex "--EOF")
+ , testCase "Binary/unary operator parsing/printing" $ do
+ pp "2^3^2 == 2^(3^2)"
+ pp "2^3*4 == (2^3)*4"
+ pp "2^-2 == 1/4 and -2^- -2 == - - -4"
+ pp "not nil and 2 and not(2>3 or 3<2)"
+ pp "-3-1-5 == 0+0-9"
+ pp "-2^2 == -4 and (-2)^2 == 4 and 2*2-3-1 == 0"
+ pp "2*1+3/3 == 3 and 1+2 .. 3*1 == \"33\""
+ pp "not(2+1 > 3*1) and \"a\"..\"b\" > \"a\""
+ pp "not ((true or false) and nil)"
+ pp "true or false and nil"
+ pp "(((1 or false) and true) or false) == true"
+ pp "(((nil and true) or false) and true) == false"
]
+ where
+ pp :: String -> Assertion
+ pp expr =
+ case P.parseText P.exp expr of
+ Left err -> assertFailure $ "Parsing failed: " ++ show err
+ Right expr' ->
+ assertEqual "Printed string is not equal to original one modulo whitespace"
+ (filter (not . isSpace) expr) (filter (not . isSpace) (show $ pprint expr'))
+
parseFilesTest :: String -> FilePath -> TestTree
parseFilesTest msg root = testCase msg $ do

0 comments on commit b4bebe3

Please sign in to comment.