language-lua 0.1.7 → 0.2.0

raw patch · 5 files changed

+529/−310 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• language-lua.cabal +7/−1
• src/Language/Lua/Lexer.x +2/−2
• src/Language/Lua/Parser.hs +187/−156
• src/Language/Lua/PrettyPrinter.hs +88/−82
• src/Language/Lua/Types.hs +245/−69

@@ -1,6 +1,12 @@ Name:                language-lua Description:         Lua 5.2 lexer, parser and pretty-printer.-Version:             0.1.7+                     .+                     Changelog:+                     .+                     \0.2.0:+                     .+                     - Syntax tree is annotated. All parsers(`parseText`, `parseFile`) annotate resulting tree with source positions.+Version:             0.2.0 Synopsis:            Lua parser and pretty-printer Homepage:            http://github.com/osa1/language-lua Bug-reports:         http://github.com/osa1/language-lua/issues

@@ -27,8 +27,8 @@ $longstr  = \0-\255                      -- valid character in a long string  -- escape characters-@charescd  = '\\' ([ntvbrfaeE\\\?\"] | $octdigit{1,3} | x$hexdigit+ | X$hexdigit+)-@charescs  = '\\' ([ntvbrfaeE\\\?\'] | $octdigit{1,3} | x$hexdigit+ | X$hexdigit+)+@charescd  = \\ ([ntvbrfaeE\\\?\"] | $octdigit{1,3} | x$hexdigit+ | X$hexdigit+)+@charescs  = \\ ([ntvbrfaeE\\\?\'] | $octdigit{1,3} | x$hexdigit+ | X$hexdigit+)  @digits    = $digit+ @hexdigits = $hexdigit+

@@ -20,16 +20,16 @@ import Text.Parsec.LTok import Text.Parsec.Expr import Control.Applicative ((<*), (<$>), (<*>))-import Control.Monad (void, liftM)+import Control.Monad (liftM)  -- | Runs Lua lexer before parsing. Use @parseText stat@ to parse -- statements, and @parseText exp@ to parse expressions. parseText :: Parsec [LTok] () a -> String -> Either ParseError a-parseText p s = parse p "lua" (llex s)+parseText p s = parse p "<string>" (llex s)  -- | Parse a Lua file. You can use @parseText chunk@ to parse a file from a string.-parseFile :: FilePath -> IO (Either ParseError Block)-parseFile = liftM (parseText chunk) . readFile+parseFile :: FilePath -> IO (Either ParseError (Block SourcePos))+parseFile path = parse chunk path . llex <$> readFile path  parens :: Monad m => ParsecT [LTok] u m a -> ParsecT [LTok] u m a parens = between (tok LTokLParen) (tok LTokRParen)@@ -37,210 +37,233 @@ brackets :: Monad m => ParsecT [LTok] u m a -> ParsecT [LTok] u m a brackets = between (tok LTokLBracket) (tok LTokRBracket) -name :: Parser String-name = tokenValue <$> anyIdent+name :: Parser (Name SourcePos)+name = do+    pos <- getPosition+    str <- tokenValue <$> anyIdent+    return $ Name pos str  number :: Parser String number = tokenValue <$> anyNum  -data PrimaryExp-    = PName Name-    | PParen Exp+data PrimaryExp a+    = PName a (Name a)+    | PParen a (Exp a)     deriving (Show, Eq) -data SuffixedExp-    = SuffixedExp PrimaryExp [SuffixExp]+data SuffixedExp a+    = SuffixedExp a (PrimaryExp a) [SuffixExp a]     deriving (Show, Eq) -data SuffixExp-    = SSelect Name-    | SSelectExp Exp-    | SSelectMethod Name FunArg-    | SFunCall FunArg+data SuffixExp a+    = SSelect a (Name a)+    | SSelectExp a (Exp a)+    | SSelectMethod a (Name a) (FunArg a)+    | SFunCall a (FunArg a)     deriving (Show, Eq) -primaryExp :: Parser PrimaryExp-primaryExp = (PName <$> name) <|> (liftM PParen $ parens exp)+primaryExp :: Parser (PrimaryExp SourcePos)+primaryExp = do+    pos <- getPosition+    PName pos <$> name <|> PParen pos <$> parens exp -suffixedExp :: Parser SuffixedExp-suffixedExp = SuffixedExp <$> primaryExp <*> many suffixExp+suffixedExp :: Parser (SuffixedExp SourcePos)+suffixedExp = SuffixedExp <$> getPosition <*> primaryExp <*> many suffixExp -suffixExp :: Parser SuffixExp+suffixExp :: Parser (SuffixExp SourcePos) suffixExp = selectName <|> selectExp <|> selectMethod <|> funarg-  where selectName   = SSelect <$> (tok LTokDot >> name)-        selectExp    = SSelectExp <$> brackets exp-        selectMethod = tok LTokColon >> (SSelectMethod <$> name <*> funArg)-        funarg       = SFunCall <$> funArg+  where selectName   = SSelect <$> getPosition <*> (tok LTokDot >> name)+        selectExp    = SSelectExp <$> getPosition <*> brackets exp+        selectMethod = do+          pos <- getPosition+          tok LTokColon+          SSelectMethod pos <$> name <*> funArg+        funarg       = SFunCall <$> getPosition <*> funArg -sexpToPexp :: SuffixedExp -> PrefixExp-sexpToPexp (SuffixedExp t r) = case r of-    []                            -> t'-    (SSelect sname:xs)            -> iter xs (PEVar (SelectName t' sname))-    (SSelectExp sexp:xs)          -> iter xs (PEVar (Select t' sexp))-    (SSelectMethod mname args:xs) -> iter xs (PEFunCall (MethodCall t' mname args))-    (SFunCall args:xs)            -> iter xs (PEFunCall (NormalFunCall t' args))+sexpToPexp :: SuffixedExp SourcePos -> PrefixExp SourcePos+sexpToPexp (SuffixedExp _ t r) = case r of+    []                                -> t'+    (SSelect pos sname:xs)            -> iter xs (PEVar     pos (SelectName pos t' sname))+    (SSelectExp pos sexp:xs)          -> iter xs (PEVar     pos (Select pos t' sexp))+    (SSelectMethod pos mname args:xs) -> iter xs (PEFunCall pos (MethodCall pos t' mname args))+    (SFunCall pos args:xs)            -> iter xs (PEFunCall pos (NormalFunCall pos t' args)) -  where t' :: PrefixExp+  where t' :: PrefixExp SourcePos         t' = case t of-               PName name -> PEVar (Name name)-               PParen exp -> Paren exp+               PName pos name -> PEVar pos (VarName pos name)+               PParen pos exp -> Paren pos exp -        iter :: [SuffixExp] -> PrefixExp -> PrefixExp-        iter [] pe                            = pe-        iter (SSelect sname:xs) pe            = iter xs (PEVar (SelectName pe sname))-        iter (SSelectExp sexp:xs) pe          = iter xs (PEVar (Select pe sexp))-        iter (SSelectMethod mname args:xs) pe = iter xs (PEFunCall (MethodCall pe mname args))-        iter (SFunCall args:xs) pe            = iter xs (PEFunCall (NormalFunCall pe args))+        iter :: [SuffixExp SourcePos] -> PrefixExp SourcePos -> PrefixExp SourcePos+        iter [] pe                                = pe+        iter (SSelect pos sname:xs) pe            = iter xs (PEVar pos (SelectName pos pe sname))+        iter (SSelectExp pos sexp:xs) pe          = iter xs (PEVar pos (Select pos pe sexp))+        iter (SSelectMethod pos mname args:xs) pe = iter xs (PEFunCall pos (MethodCall pos pe mname args))+        iter (SFunCall pos args:xs) pe            = iter xs (PEFunCall pos (NormalFunCall pos pe args))  -- TODO: improve error messages.-sexpToVar :: SuffixedExp -> Parser Var-sexpToVar (SuffixedExp (PName name) []) = return (Name name)-sexpToVar (SuffixedExp _ []) = fail "syntax error"+sexpToVar :: SuffixedExp SourcePos -> Parser (Var SourcePos)+sexpToVar (SuffixedExp pos (PName _ name) []) = return (VarName pos name)+sexpToVar (SuffixedExp _ _ []) = fail "syntax error" sexpToVar sexp = case sexpToPexp sexp of-                   PEVar var -> return var+                   PEVar _ var -> return var                    _ -> fail "syntax error" -sexpToFunCall :: SuffixedExp -> Parser FunCall-sexpToFunCall (SuffixedExp _ []) = fail "syntax error"+sexpToFunCall :: SuffixedExp SourcePos -> Parser (FunCall SourcePos)+sexpToFunCall (SuffixedExp _ _ []) = fail "syntax error" sexpToFunCall sexp = case sexpToPexp sexp of-                       PEFunCall funcall -> return funcall+                       PEFunCall _ funcall -> return funcall                        _ -> fail "syntax error" -var :: Parser Var+var :: Parser (Var SourcePos) var = suffixedExp >>= sexpToVar -funCall :: Parser FunCall+funCall :: Parser (FunCall SourcePos) funCall = suffixedExp >>= sexpToFunCall  stringlit :: Parser String stringlit = tokenValue <$> string -funArg :: Parser FunArg-funArg = tableArg <|> stringArg <|> parlist-  where tableArg  = TableArg <$> table-        stringArg = StringArg <$> stringlit-        parlist   = parens (do exps <- exp `sepBy` tok LTokComma-                               return $ Args exps)+funArg :: Parser (FunArg SourcePos)+funArg = tableArg <|> stringArg <|> arglist+  where tableArg  = TableArg <$> getPosition <*> table+        stringArg = StringArg <$> getPosition <*> stringlit+        arglist   = do+          pos <- getPosition+          parens (do exps <- exp `sepBy` tok LTokComma+                     return $ Args pos exps) -funBody :: Parser FunBody+funBody :: Parser (FunBody SourcePos) funBody = do-    (params, vararg) <- parlist+    pos <- getPosition+    (params, vararg) <- arglist     body <- block     tok LTokEnd-    return $ FunBody params vararg body+    return $ FunBody pos params vararg body -  where parlist = parens $ do+  where lastarg = do+          pos <- getPosition+          arg <- optionMaybe (tok LTokEllipsis <|> tok LTokComma)+          case arg of+            Just LTokEllipsis -> return (Just pos)+            _ -> return Nothing++        arglist = parens $ do           vars <- name `sepEndBy` tok LTokComma-          vararg <- optionMaybe (tok LTokEllipsis <|> tok LTokComma)-          return $ case vararg of-                       Nothing -> (vars, False)-                       Just LTokEllipsis -> (vars, True)-                       _ -> (vars, False)+          vararg <- lastarg+          return (vars, vararg) -block :: Parser Block+block :: Parser (Block SourcePos) block = do+  pos <- getPosition   stats <- many stat   ret <- optionMaybe retstat-  return $ Block stats ret+  return $ Block pos stats ret -retstat :: Parser [Exp]+retstat :: Parser [Exp SourcePos] retstat = do   tok LTokReturn   exps <- exp `sepBy` tok LTokComma   optional (tok LTokSemic)   return exps -tableField :: Parser TableField+tableField :: Parser (TableField SourcePos) tableField = choice [ expField, try namedField, field ]-  where expField :: Parser TableField+  where expField :: Parser (TableField SourcePos)         expField = do+            pos <- getPosition             e1 <- brackets exp             tok LTokAssign             e2 <- exp-            return $ ExpField e1 e2+            return $ ExpField pos e1 e2 -        namedField :: Parser TableField+        namedField :: Parser (TableField SourcePos)         namedField = do+            pos <- getPosition             name' <- name             tok LTokAssign             val <- exp-            return $ NamedField name' val+            return $ NamedField pos name' val -        field :: Parser TableField-        field = Field <$> exp+        field :: Parser (TableField SourcePos)+        field = Field <$> getPosition <*> exp -table :: Parser Table-table = between (tok LTokLBrace)-                (tok LTokRBrace)-                (do fields <- tableField `sepEndBy` fieldSep-                    return $ Table fields)+table :: Parser (Table SourcePos)+table = do+    pos <- getPosition+    between (tok LTokLBrace)+            (tok LTokRBrace)+            (do fields <- tableField `sepEndBy` fieldSep+                return $ Table pos fields)   where fieldSep = tok LTokComma <|> tok LTokSemic  ----------------------------------------------------------------------- ---- Expressions  nilExp, boolExp, numberExp, stringExp, varargExp, fundefExp,-  prefixexpExp, tableconstExp, opExp, exp, exp' :: Parser Exp+  prefixexpExp, tableconstExp, exp, exp' :: Parser (Exp SourcePos) -nilExp = tok LTokNil >> return Nil+nilExp = (Nil <$> getPosition) <* tok LTokNil -boolExp = (tok LTokTrue >> return (Bool True)) <|>-            (tok LTokFalse >> return (Bool False))+boolExp = do+    pos <- getPosition+    tOrF <- tok LTokTrue <|> tok LTokFalse+    return $ Bool pos (tOrF == LTokTrue) -numberExp = Number <$> number+numberExp = Number <$> getPosition <*> number -stringExp = String <$> stringlit+stringExp = String <$> getPosition <*> stringlit -varargExp = tok LTokEllipsis >> return Vararg+varargExp = (Vararg <$> getPosition) <* tok LTokEllipsis  fundefExp = do+  pos <- getPosition   tok LTokFunction   body <- funBody-  return $ EFunDef (FunDef body)--prefixexpExp = PrefixExp <$> (liftM sexpToPexp suffixedExp)+  return $ EFunDef pos (FunDef (ann body) body) -tableconstExp = TableConst <$> table+prefixexpExp = PrefixExp <$> getPosition <*> liftM sexpToPexp suffixedExp -binary :: Monad m => LToken -> (a -> a -> a) -> Assoc -> Operator [LTok] u m a-binary op fun = Infix (tok op >> return fun)+tableconstExp = TableConst <$> getPosition <*> table -prefix :: Monad m => LToken -> (a -> a) -> Operator [LTok] u m a-prefix op fun = Prefix (tok op >> return fun)+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) -opTable :: Monad m => [[Operator [LTok] u m Exp]]-opTable = [ [ binary LTokExp       (Binop Exp)    AssocRight ]-          , [ prefix LTokNot       (Unop Not)-            , prefix LTokSh        (Unop Len)-            , prefix LTokMinus     (Unop Neg)-            ]-          , [ binary LTokStar      (Binop Mul)    AssocLeft-            , binary LTokSlash     (Binop Div)    AssocLeft-            , binary LTokPercent   (Binop Mod)    AssocLeft-            ]-          , [ binary LTokPlus      (Binop Add)    AssocLeft-            , binary LTokMinus     (Binop Sub)    AssocLeft-            ]-          , [ binary LTokDDot      (Binop Concat) AssocRight ]-          , [ binary LTokGT        (Binop GT)     AssocLeft-            , binary LTokLT        (Binop LT)     AssocLeft-            , binary LTokGEq       (Binop GTE)    AssocLeft-            , binary LTokLEq       (Binop LTE)    AssocLeft-            , binary LTokNotequal  (Binop NEQ)    AssocLeft-            , binary LTokEqual     (Binop EQ)     AssocLeft-            ]-          , [ binary LTokAnd       (Binop And)    AssocLeft ]-          , [ binary LTokOr        (Binop Or)     AssocLeft ]-          ]+prefix :: Monad m => LToken -> (SourcePos -> a -> a) -> Operator [LTok] u m a+prefix op fun = Prefix (do pos <- getPosition; tok op; return $ fun pos) -opExp = buildExpressionParser opTable exp' <?> "opExp"+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 ]  -- | Expression parser.-exp = choice [ opExp, nilExp, boolExp, numberExp, stringExp, varargExp,+exp = choice [ opExp =<< getPosition, nilExp, boolExp, numberExp, stringExp, varargExp,                fundefExp, prefixexpExp, tableconstExp ]  -----------------------------------------------------------------------@@ -248,69 +271,72 @@  emptyStat, assignStat, funCallStat, labelStat, breakStat, gotoStat,     doStat, whileStat, repeatStat, ifStat, forRangeStat, forInStat,-    funAssignStat, localFunAssignStat, localAssignStat, stat :: Parser Stat+    funAssignStat, localFunAssignStat, localAssignStat, stat :: Parser (Stat SourcePos) -emptyStat = void (tok LTokSemic) >> return EmptyStat+emptyStat = (EmptyStat <$> getPosition) <* tok LTokSemic  assignStat = do+  pos <- getPosition   vars <- var `sepBy` tok LTokComma   tok LTokAssign   exps <- exp `sepBy` tok LTokComma-  return $ Assign vars exps+  return $ Assign pos vars exps -funCallStat = FunCall <$> funCall+funCallStat = FunCall <$> getPosition <*> funCall -labelStat = Label <$> label+labelStat = Label <$> getPosition <*> label   where label = between (tok LTokDColon) (tok LTokDColon) name -breakStat = tok LTokBreak >> return Break+breakStat = (Break <$> getPosition) <* tok LTokBreak -gotoStat = Goto <$> (tok LTokGoto >> name)+gotoStat = Goto <$> getPosition <*> (tok LTokGoto >> name) -doStat = Do <$> between (tok LTokDo) (tok LTokEnd) block+doStat = Do <$> getPosition <*> between (tok LTokDo) (tok LTokEnd) block -whileStat =+whileStat = do+  pos <- getPosition   between (tok LTokWhile)           (tok LTokEnd)           (do cond <- exp               tok LTokDo               body <- block-              return $ While cond body)+              return $ While pos cond body)  repeatStat = do+  pos <- getPosition   tok LTokRepeat   body <- block   tok LTokUntil   cond <- exp-  return $ Repeat body cond+  return $ Repeat pos body cond -ifStat =+ifStat = do+    pos <- getPosition     between (tok LTokIf)             (tok LTokEnd)             (do f <- ifPart                 conds <- many elseifPart                 l <- optionMaybe elsePart-                return $ If (f:conds) l)+                return $ If pos (f:conds) l) -  where ifPart :: Parser (Exp, Block)-        ifPart = do-            cond <- exp-            tok LTokThen-            body <- block-            return (cond, body)+  where ifPart :: Parser (Exp SourcePos, Block SourcePos)+        ifPart = cond -        elseifPart :: Parser (Exp, Block)-        elseifPart = do-            tok LTokElseIf+        elseifPart :: Parser (Exp SourcePos, Block SourcePos)+        elseifPart = tok LTokElseIf >> cond++        cond :: Parser (Exp SourcePos, Block SourcePos)+        cond = do             cond <- exp             tok LTokThen             body <- block             return (cond, body) -        elsePart :: Parser Block+        elsePart :: Parser (Block SourcePos)         elsePart = tok LTokElse >> block -forRangeStat =+forRangeStat = do+  pos <- getPosition   between (tok LTokFor)           (tok LTokEnd)           (do name' <- name@@ -321,9 +347,10 @@               range <- optionMaybe $ tok LTokComma >> exp               tok LTokDo               body <- block-              return $ ForRange name' start end range body)+              return $ ForRange pos name' start end range body) -forInStat =+forInStat = do+  pos <- getPosition   between (tok LTokFor)           (tok LTokEnd)           (do names <- name `sepBy` tok LTokComma@@ -331,30 +358,34 @@               exps <- exp `sepBy` tok LTokComma               tok LTokDo               body <- block-              return $ ForIn names exps body)+              return $ ForIn pos names exps body)  funAssignStat = do+    pos <- getPosition     tok LTokFunction     name' <- funName     body <- funBody-    return $ FunAssign name' body-  where funName :: Parser FunName-        funName = FunName <$> name-                          <*> optionMaybe (tok LTokDot >> name)-                          <*> many (tok LTokColon >> name)+    return $ FunAssign pos name' body+  where funName :: Parser (FunName SourcePos)+        funName = FunName <$> getPosition+                          <*> name+                          <*> many (tok LTokDot >> name)+                          <*> optionMaybe (tok LTokColon >> name)  localFunAssignStat = do+  pos <- getPosition   tok LTokLocal   tok LTokFunction   name' <- name   body <- funBody-  return $ LocalFunAssign name' body+  return $ LocalFunAssign pos name' body  localAssignStat = do+  pos <- getPosition   tok LTokLocal   names <- name `sepBy` tok LTokComma   rest <- optionMaybe $ tok LTokAssign >> exp `sepBy` tok LTokComma-  return $ LocalAssign names rest+  return $ LocalAssign pos names rest  -- | Statement parser. stat =@@ -376,5 +407,5 @@          ]  -- | Lua file parser.-chunk :: Parser Block+chunk :: Parser (Block SourcePos) chunk = block <* tok LTokEof

@@ -30,60 +30,63 @@     pprint True  = text "true"     pprint False = text "false" -instance LPretty Exp where-    pprint Nil              = text "nil"-    pprint (Bool s)         = pprint s-    pprint (Number n)       = text n-    pprint (String s)       = dquotes (text s)-    pprint Vararg           = text "..."-    pprint (EFunDef f)      = pprint f-    pprint (PrefixExp pe)   = pprint pe-    pprint (TableConst t)   = pprint t-    pprint (Binop op e1 e2) = pprint e1 <+> pprint op <+> pprint e2-    pprint (Unop op e)      = pprint op <> pprint e+instance LPretty (Name a) where+    pprint (Name _ s) = text s -instance LPretty Var where-    pprint (Name n)             = text n-    pprint (Select pe e)        = pprint pe <> brackets (pprint e)-    pprint (SelectName pe name) = group (pprint pe <$$> (char '.' <> pprint name))+instance LPretty (Exp a) where+    pprint (Nil _)            = text "nil"+    pprint (Bool _ s)         = pprint s+    pprint (Number _ n)       = text n+    pprint (String _ s)       = dquotes (text s)+    pprint (Vararg _)         = text "..."+    pprint (EFunDef _ f)      = pprint f+    pprint (PrefixExp _ pe)   = pprint pe+    pprint (TableConst _ t)   = pprint t+    pprint (Binop _ op e1 e2) = pprint e1 <+> pprint op <+> pprint e2+    pprint (Unop _ op e)      = pprint op <> pprint e -instance LPretty Binop where-    pprint Add    = char '+'-    pprint Sub    = char '-'-    pprint Mul    = char '*'-    pprint Div    = char '/'-    pprint Exp    = char '^'-    pprint Mod    = char '%'-    pprint Concat = text ".."-    pprint LT     = char '<'-    pprint LTE    = text "<="-    pprint GT     = char '>'-    pprint GTE    = text ">="-    pprint EQ     = text "=="-    pprint NEQ    = text "~="-    pprint And    = text "and"-    pprint Or     = text "or"+instance LPretty (Var a) where+    pprint (VarName _ n)          = pprint n+    pprint (Select _ pe e)        = pprint pe <> brackets (pprint e)+    pprint (SelectName _ pe name) = group (pprint pe <$$> (char '.' <> pprint name)) -instance LPretty Unop where-    pprint Neg = char '-'-    pprint Not = text "not "-    pprint Len = char '#'+instance LPretty (Binop a) where+    pprint Add{}    = char '+'+    pprint Sub{}    = char '-'+    pprint Mul{}    = char '*'+    pprint Div{}    = char '/'+    pprint Exp{}    = char '^'+    pprint Mod{}    = char '%'+    pprint Concat{} = text ".."+    pprint LT{}     = char '<'+    pprint LTE{}    = text "<="+    pprint GT{}     = char '>'+    pprint GTE{}    = text ">="+    pprint EQ{}     = text "=="+    pprint NEQ{}    = text "~="+    pprint And{}    = text "and"+    pprint Or{}     = text "or" -instance LPretty PrefixExp where-    pprint (PEVar var)         = pprint var-    pprint (PEFunCall funcall) = pprint funcall-    pprint (Paren e)           = parens (pprint e)+instance LPretty (Unop a) where+    pprint Neg{} = char '-'+    pprint Not{} = text "not "+    pprint Len{} = char '#' -instance LPretty Table where-    pprint (Table fields) = braces (nest 4 (cat (punctuate comma (map pprint fields))))+instance LPretty (PrefixExp a) where+    pprint (PEVar _ var)         = pprint var+    pprint (PEFunCall _ funcall) = pprint funcall+    pprint (Paren _ e)           = parens (pprint e) -instance LPretty TableField where-    pprint (ExpField e1 e2)    = brackets (pprint e1) <+> equals <+> pprint e2-    pprint (NamedField name e) = pprint name <+> equals <+> pprint e-    pprint (Field e)           = pprint e+instance LPretty (Table a) where+    pprint (Table _ fields) = braces (nest 4 (cat (punctuate comma (map pprint fields)))) -instance LPretty Block where-    pprint (Block stats ret)+instance LPretty (TableField a) where+    pprint (ExpField _ e1 e2)    = brackets (pprint e1) <+> equals <+> pprint e2+    pprint (NamedField _ name e) = pprint name <+> equals <+> pprint e+    pprint (Field _ e)           = pprint e++instance LPretty (Block a) where+    pprint (Block _ stats ret)         = case stats of             [] -> ret'             _  -> (foldr (<$>) empty (map pprint stats)) <$> ret'@@ -91,56 +94,59 @@                      Nothing -> empty                      Just e  -> nest 2 (text "return" </> (intercalate comma (map pprint e))) -instance LPretty FunName where-    pprint (FunName name s methods) = text name <> s' <> (intercalate colon (map pprint methods))-      where s' = case s of-                   Nothing -> empty-                   Just s' -> char '.' <> text s'+instance LPretty (FunName a) where+    pprint (FunName _ name s methods) = cat (punctuate dot (map pprint $ name:s)) <> method'+      where method' = case methods of+                        Nothing -> empty+                        Just m' -> char ':' <> pprint m' -instance LPretty FunDef where-    pprint (FunDef body) = pprint body+instance LPretty (FunDef a) where+    pprint (FunDef _ body) = pprint body -instance LPretty FunBody where+instance LPretty (FunBody a) where     pprint funbody = pprintFunction Nothing funbody -pprintFunction :: Maybe Doc -> FunBody -> Doc-pprintFunction funname (FunBody args vararg block)+pprintFunction :: Maybe Doc -> FunBody a -> Doc+pprintFunction funname (FunBody _ args vararg block)     = group (nest 4 (funhead <$> funbody) <$> end)   where funhead = case funname of                     Nothing -> nest 2 (text "function" </> args')                     Just n  -> nest 2 (text "function" </> n </> args')+        vararg' = case vararg of+                    Nothing -> []+                    Just pos -> [Name pos "..."]         args' = parens (align (cat (punctuate (comma <> space)-                                        (map pprint (args ++ if vararg then ["..."] else [])))))+                                        (map pprint (args ++ vararg')))))         funbody = pprint block         end = text "end" -instance LPretty FunCall where-    pprint (NormalFunCall pe arg)     = group (nest 4 (pprint pe <$$> pprint arg))-    pprint (MethodCall pe method arg) = group (nest 4 (pprint pe <$$> (colon <> text method) <$$> pprint arg))+instance LPretty (FunCall a) where+    pprint (NormalFunCall _ pe arg)     = group (nest 4 (pprint pe <$$> pprint arg))+    pprint (MethodCall _ pe method arg) = group (nest 4 (pprint pe <$$> (colon <> pprint method) <$$> pprint arg)) -instance LPretty FunArg where-    pprint (Args exps)   = parens (nest 4 (cat (punctuate (comma <> space) (map pprint exps))))-    pprint (TableArg t)  = pprint t-    pprint (StringArg s) = dquotes (text s)+instance LPretty (FunArg a) where+    pprint (Args _ exps)   = parens (nest 4 (cat (punctuate (comma <> space) (map pprint exps))))+    pprint (TableArg _ t)  = pprint t+    pprint (StringArg _ s) = dquotes (text s) -instance LPretty Stat where-    pprint (Assign names vals)+instance LPretty (Stat a) where+    pprint (Assign _ names vals)         =   (intercalate comma (map pprint names))         <+> equals         <+> (intercalate comma (map pprint vals))-    pprint (FunCall funcall) = pprint funcall-    pprint (Label name)      = text "::" <> text name <> text "::"-    pprint Break             = text "break"-    pprint (Goto name)       = text "goto" <+> text name-    pprint (Do block)        = group (nest 4 (text "do" <$> pprint block) <$> text "end")-    pprint (While guard e)+    pprint (FunCall _ funcall) = pprint funcall+    pprint (Label _ name)      = text "::" <> pprint name <> text "::"+    pprint (Break _)           = text "break"+    pprint (Goto _ name)       = text "goto" <+> pprint name+    pprint (Do _ block)        = group (nest 4 (text "do" <$> pprint block) <$> text "end")+    pprint (While _ guard e)         =  (nest 4 (text "while" <+> pprint guard <+> text "do"                    </> indent 4 (pprint e)))        </> text "end"-    pprint (Repeat block guard)+    pprint (Repeat _ block guard)         = nest 4 (text "repeat" </> pprint block) </> (nest 4 (text "until" </> pprint guard)) -    pprint (If cases elsePart) = group (printIf cases elsePart)+    pprint (If _ cases elsePart) = group (printIf cases elsePart)       where printIf ((guard, block):xs) e                 =   group (nest 4 (text "if" <+> pprint guard <+> text "then"                         <$> pprint block))@@ -154,25 +160,25 @@                         <$> pprint block))                 <$> printIf' xs e -    pprint (ForRange name e1 e2 e3 block)-        =   text "for" <+> text name <> equals <> pprint e1 <> comma <> pprint e2 <> e3' <+> text "do"+    pprint (ForRange _ name e1 e2 e3 block)+        =   text "for" <+> pprint name <> equals <> pprint e1 <> comma <> pprint e2 <> e3' <+> text "do"         <$> indent 4 (pprint block)         <$> text "end"       where e3' = case e3 of                     Nothing -> empty                     Just e  -> comma <> pprint e -    pprint (ForIn names exps block)+    pprint (ForIn _ names exps block)         =   text "for" <+> (intercalate comma (map pprint names))                 <+> text "in" <+> (intercalate comma (map pprint exps)) <+> text "do"         <$> indent 4 (pprint block)         <$> text "end" -    pprint (FunAssign name body) = pprintFunction (Just (pprint name)) body-    pprint (LocalFunAssign name body) = text "local" <+> pprintFunction (Just (pprint name)) body-    pprint (LocalAssign names exps)+    pprint (FunAssign _ name body) = pprintFunction (Just (pprint name)) body+    pprint (LocalFunAssign _ name body) = text "local" <+> pprintFunction (Just (pprint name)) body+    pprint (LocalAssign _ names exps)         = text "local" <+> (intercalate comma (map pprint names)) <+> equals <+> exps'       where exps' = case exps of                       Nothing -> empty                       Just es -> intercalate comma (map pprint es)-    pprint EmptyStat = empty+    pprint EmptyStat{} = empty

@@ -1,88 +1,264 @@ {-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DeriveFunctor #-} -- | Lua 5.2 syntax tree, as specified in <http://www.lua.org/manual/5.2/manual.html#9>.++-- Annotation implementation is inspired by haskell-src-exts.+ module Language.Lua.Types where -type Name = String+import Prelude hiding (LT, EQ, GT) -data Stat-    = Assign [Var] [Exp] -- ^var1, var2 .. = exp1, exp2 ..-    | FunCall FunCall -- ^function call-    | Label Name -- ^label for goto-    | Break -- ^break-    | Goto Name -- ^goto label-    | Do Block -- ^do .. end-    | While Exp Block -- ^while .. do .. end-    | Repeat Block Exp -- ^repeat .. until ..-    | If [(Exp, Block)] (Maybe Block) -- ^if .. then .. [elseif ..] [else ..] end-    | ForRange Name Exp Exp (Maybe Exp) Block -- ^for x=start, end [, step] do .. end-    | ForIn [Name] [Exp] Block -- ^for x in .. do .. end-    | FunAssign FunName FunBody -- ^function \<var\> (..) .. end-    | LocalFunAssign Name FunBody -- ^local function \<var\> (..) .. end-    | LocalAssign [Name] (Maybe [Exp]) -- ^local var1, var2 .. = exp1, exp2 ..-    | EmptyStat -- ^/;/-    deriving (Show, Eq)+data Name a = Name a String deriving (Show, Eq, Functor) -data Exp-    = Nil-    | Bool Bool-    | Number String-    | String String-    | Vararg -- ^/.../-    | EFunDef FunDef -- ^/function (..) .. end/-    | PrefixExp PrefixExp-    | TableConst Table -- ^table constructor-    | Binop Binop Exp Exp -- ^binary operators, /+ - * ^ % .. < <= > >= == ~= and or/-    | Unop Unop Exp -- ^unary operators, /- not #/-    deriving (Show, Eq)+data Stat a+    = Assign a [Var a] [Exp a] -- ^var1, var2 .. = exp1, exp2 ..+    | FunCall a (FunCall a) -- ^function call+    | Label a (Name a) -- ^label for goto+    | Break a -- ^break+    | Goto a (Name a) -- ^goto label+    | Do a (Block a) -- ^do .. end+    | While a (Exp a) (Block a) -- ^while .. do .. end+    | Repeat a (Block a) (Exp a) -- ^repeat .. until ..+    | If a [(Exp a, Block a)] (Maybe (Block a)) -- ^if .. then .. [elseif ..] [else ..] end+    | ForRange a (Name a) (Exp a) (Exp a) (Maybe (Exp a)) (Block a) -- ^for x=start, end [, step] do .. end+    | ForIn a [Name a] [Exp a] (Block a) -- ^for x in .. do .. end+    | FunAssign a (FunName a) (FunBody a) -- ^function \<var\> (..) .. end+    | LocalFunAssign a (Name a) (FunBody a) -- ^local function \<var\> (..) .. end+    | LocalAssign a [Name a] (Maybe [Exp a]) -- ^local var1, var2 .. = exp1, exp2 ..+    | EmptyStat a -- ^/;/+    deriving (Show, Eq, Functor) -data Var-    = Name Name -- ^variable-    | Select PrefixExp Exp -- ^/table[exp]/-    | SelectName PrefixExp Name -- ^/table.variable/-    deriving (Show, Eq)+data Exp a+    = Nil a+    | Bool a Bool+    | Number a String+    | String a String+    | Vararg a -- ^/.../+    | EFunDef a (FunDef a) -- ^/function (..) .. end/+    | PrefixExp a (PrefixExp a)+    | TableConst a (Table a) -- ^table constructor+    | Binop a (Binop a) (Exp a) (Exp a) -- ^binary operators, /+ - * ^ % .. < <= > >= == ~= and or/+    | Unop a (Unop a) (Exp a) -- ^unary operators, /- not #/+    deriving (Show, Eq, Functor) -data Binop = Add | Sub | Mul | Div | Exp | Mod | Concat-    | LT | LTE | GT | GTE | EQ | NEQ | And | Or-    deriving (Show, Eq)+data Var a+    = VarName a (Name a) -- ^variable+    | Select a (PrefixExp a) (Exp a) -- ^/table[exp]/+    | SelectName a (PrefixExp a) (Name a) -- ^/table.variable/+    deriving (Show, Eq, Functor) -data Unop = Neg | Not | Len-    deriving (Show, Eq)+data Binop a = Add a | Sub a | Mul a | Div a | Exp a | Mod a | Concat a+    | LT a | LTE a | GT a | GTE a | EQ a | NEQ a | And a | Or a+    deriving (Show, Eq, Functor) -data PrefixExp-    = PEVar Var-    | PEFunCall FunCall-    | Paren Exp-    deriving (Show, Eq)+data Unop a = Neg a | Not a | Len a+    deriving (Show, Eq, Functor) -data Table = Table [TableField] -- ^list of table fields-    deriving (Show, Eq)+data PrefixExp a+    = PEVar a (Var a)+    | PEFunCall a (FunCall a)+    | Paren a (Exp a)+    deriving (Show, Eq, Functor) -data TableField-    = ExpField Exp Exp -- ^/[exp] = exp/-    | NamedField Name Exp -- ^/name = exp/-    | Field Exp-    deriving (Show, Eq)+data Table a = Table a [TableField a] -- ^list of table fields+    deriving (Show, Eq, Functor) +data TableField a+    = ExpField a (Exp a) (Exp a) -- ^/[exp] = exp/+    | NamedField a (Name a) (Exp a) -- ^/name = exp/+    | Field a (Exp a)+    deriving (Show, Eq, Functor)+ -- | A block is list of statements with optional return statement.-data Block = Block [Stat] (Maybe [Exp])-    deriving (Show, Eq)+data Block a = Block a [Stat a] (Maybe [Exp a])+    deriving (Show, Eq, Functor) -data FunName = FunName Name (Maybe Name) [Name]-    deriving (Show, Eq)+data FunName a = FunName a (Name a) [Name a] (Maybe (Name a))+    deriving (Show, Eq, Functor) -data FunDef = FunDef FunBody-    deriving (Show, Eq)+data FunDef a = FunDef a (FunBody a)+    deriving (Show, Eq, Functor) -data FunBody = FunBody [Name] Bool Block -- ^(args, vararg predicate, block)-    deriving (Show, Eq)+data FunBody a = FunBody a [Name a] (Maybe a) (Block a) -- ^(args, vararg, block)+    deriving (Show, Eq, Functor) -data FunCall-    = NormalFunCall PrefixExp FunArg -- ^/prefixexp ( funarg )/-    | MethodCall PrefixExp Name FunArg -- ^/prefixexp : name ( funarg )/-    deriving (Show, Eq)+data FunCall a+    = NormalFunCall a (PrefixExp a) (FunArg a) -- ^/prefixexp ( funarg )/+    | MethodCall a (PrefixExp a) (Name a) (FunArg a) -- ^/prefixexp : name ( funarg )/+    deriving (Show, Eq, Functor) -data FunArg-    = Args [Exp] -- ^list of args-    | TableArg Table -- ^table constructor-    | StringArg String -- ^string-    deriving (Show, Eq)+data FunArg a+    = Args a [Exp a] -- ^list of args+    | TableArg a (Table a) -- ^table constructor+    | StringArg a String -- ^string+    deriving (Show, Eq, Functor)+++class Functor ast => Annotated ast where+    -- | Retrieve the annotation of an AST node.+    ann :: ast l -> l+    -- | Change the annotation of an AST node. Note that only the annotation of+    --   the node itself is affected, and not the annotations of any child nodes.+    --   if all nodes in the AST tree are to be affected, use 'fmap'.+    amap :: (l -> l) -> ast l -> ast l++instance Annotated Stat where+    ann (Assign a _ _) = a+    ann (FunCall a _) = a+    ann (Label a _) = a+    ann (Break a) = a+    ann (Goto a _) = a+    ann (Do a _) = a+    ann (While a _ _) = a+    ann (Repeat a _ _) = a+    ann (If a _ _) = a+    ann (ForRange a _ _ _ _ _) = a+    ann (ForIn a _ _ _) = a+    ann (FunAssign a _ _) = a+    ann (LocalFunAssign a _ _) = a+    ann (LocalAssign a _ _) = a+    ann (EmptyStat a) = a++    amap f (Assign a x1 x2) = Assign (f a) x1 x2+    amap f (FunCall a x1) = FunCall (f a) x1+    amap f (Label a x1) = Label (f a) x1+    amap f (Break a) = Break (f a)+    amap f (Goto a x1) = Goto (f a) x1+    amap f (Do a x1) = Do (f a) x1+    amap f (While a x1 x2) = While (f a) x1 x2+    amap f (Repeat a x1 x2) = Repeat (f a) x1 x2+    amap f (If a x1 x2) = If (f a) x1 x2+    amap f (ForRange a x1 x2 x3 x4 x5) = ForRange (f a) x1 x2 x3 x4 x5+    amap f (ForIn a x1 x2 x3) = ForIn (f a) x1 x2 x3+    amap f (FunAssign a x1 x2) = FunAssign (f a) x1 x2+    amap f (LocalFunAssign a x1 x2) = LocalFunAssign (f a) x1 x2+    amap f (LocalAssign a x1 x2) = LocalAssign (f a) x1 x2+    amap f (EmptyStat a) = EmptyStat (f a)++instance Annotated Exp where+    ann (Nil a) = a+    ann (Bool a _) = a+    ann (Number a _) = a+    ann (String a _) = a+    ann (Vararg a) = a+    ann (EFunDef a _) = a+    ann (PrefixExp a _) = a+    ann (TableConst a _) = a+    ann (Binop a _ _ _) = a+    ann (Unop a _ _) = a++    amap f (Nil a) = Nil (f a)+    amap f (Bool a x1) = Bool (f a) x1+    amap f (Number a x1) = Number (f a) x1+    amap f (String a x1) = String (f a) x1+    amap f (Vararg a) = Vararg (f a)+    amap f (EFunDef a x1) = EFunDef (f a) x1+    amap f (PrefixExp a x1) = PrefixExp (f a) x1+    amap f (TableConst a x1) = TableConst (f a) x1+    amap f (Binop a x1 x2 x3) = Binop (f a) x1 x2 x3+    amap f (Unop a x1 x2) = Unop (f a) x1 x2++instance Annotated Var where+    ann (VarName a _) = a+    ann (Select a _ _) = a+    ann (SelectName a _ _) = a++    amap f (VarName a x1) = VarName (f a) x1+    amap f (Select a x1 x2) = Select (f a) x1 x2+    amap f (SelectName a x1 x2) = SelectName (f a) x1 x2++instance Annotated Binop where+    ann (Add a) = a+    ann (Sub a) = a+    ann (Mul a) = a+    ann (Div a) = a+    ann (Exp a) = a+    ann (Mod a) = a+    ann (Concat a) = a+    ann (LT a) = a+    ann (LTE a) = a+    ann (GT a) = a+    ann (GTE a) = a+    ann (EQ a) = a+    ann (NEQ a) = a+    ann (And a) = a+    ann (Or a) = a++    amap f (Add a) = Add (f a)+    amap f (Sub a) = Sub (f a)+    amap f (Mul a) = Mul (f a)+    amap f (Div a) = Div (f a)+    amap f (Exp a) = Exp (f a)+    amap f (Mod a) = Mod (f a)+    amap f (Concat a) = Concat (f a)+    amap f (LT a) = LT (f a)+    amap f (LTE a) = LTE (f a)+    amap f (GT a) = GT (f a)+    amap f (GTE a) = GTE (f a)+    amap f (EQ a) = EQ (f a)+    amap f (NEQ a) = NEQ (f a)+    amap f (And a) = And (f a)+    amap f (Or a) = Or (f a)++instance Annotated Unop where+    ann (Neg a) = a+    ann (Not a) = a+    ann (Len a) = a++    amap f (Neg a) = Neg (f a)+    amap f (Not a) = Not (f a)+    amap f (Len a) = Len (f a)++instance Annotated PrefixExp where+    ann (PEVar a _) = a+    ann (PEFunCall a _) = a+    ann (Paren a _) = a++    amap f (PEVar a x1) = PEVar (f a) x1+    amap f (PEFunCall a x1) = PEFunCall (f a) x1+    amap f (Paren a x1) = Paren (f a) x1++instance Annotated Table where+    ann (Table a _) = a+    amap f (Table a x1) = Table (f a) x1++instance Annotated TableField where+    ann (ExpField a _ _) = a+    ann (NamedField a _ _) = a+    ann (Field a _) = a++    amap f (ExpField a x1 x2) = ExpField (f a) x1 x2+    amap f (NamedField a x1 x2) = NamedField (f a) x1 x2+    amap f (Field a x1) = Field (f a) x1++instance Annotated Block where+    ann (Block a _ _) = a+    amap f (Block a x1 x2) = Block (f a) x1 x2++instance Annotated FunName where+    ann (FunName a _ _ _) = a+    amap f (FunName a x1 x2 x3) = FunName (f a) x1 x2 x3++instance Annotated FunDef where+    ann (FunDef a _) = a+    amap f (FunDef a x1) = FunDef (f a) x1++instance Annotated FunBody where+    ann (FunBody a _ _ _) = a+    amap f (FunBody a x1 x2 x3) = FunBody (f a) x1 x2 x3++instance Annotated FunCall where+    ann (NormalFunCall a _ _) = a+    ann (MethodCall a _ _ _) = a++    amap f (NormalFunCall a x1 x2) = NormalFunCall (f a) x1 x2+    amap f (MethodCall a x1 x2 x3) = MethodCall (f a) x1 x2 x3++instance Annotated FunArg where+    ann (Args a _) = a+    ann (TableArg a _) = a+    ann (StringArg a _) = a++    amap f (Args a x1) = Args (f a) x1+    amap f (TableArg a x1) = TableArg (f a) x1+    amap f (StringArg a x1) = StringArg (f a) x1