diff --git a/language-lua.cabal b/language-lua.cabal --- a/language-lua.cabal +++ b/language-lua.cabal @@ -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 diff --git a/src/Language/Lua/Lexer.x b/src/Language/Lua/Lexer.x --- a/src/Language/Lua/Lexer.x +++ b/src/Language/Lua/Lexer.x @@ -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+ diff --git a/src/Language/Lua/Parser.hs b/src/Language/Lua/Parser.hs --- a/src/Language/Lua/Parser.hs +++ b/src/Language/Lua/Parser.hs @@ -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 "" (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 diff --git a/src/Language/Lua/PrettyPrinter.hs b/src/Language/Lua/PrettyPrinter.hs --- a/src/Language/Lua/PrettyPrinter.hs +++ b/src/Language/Lua/PrettyPrinter.hs @@ -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 diff --git a/src/Language/Lua/Types.hs b/src/Language/Lua/Types.hs --- a/src/Language/Lua/Types.hs +++ b/src/Language/Lua/Types.hs @@ -1,88 +1,264 @@ {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE DeriveFunctor #-} -- | Lua 5.2 syntax tree, as specified in . + +-- 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 \ (..) .. end - | LocalFunAssign Name FunBody -- ^local function \ (..) .. 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 \ (..) .. end + | LocalFunAssign a (Name a) (FunBody a) -- ^local function \ (..) .. 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