diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Your name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Lex.hs b/app/Lex.hs new file mode 100644 --- /dev/null +++ b/app/Lex.hs @@ -0,0 +1,14 @@ +module Main where + +import Language.Lua.Lexer + +import Control.Monad +import Data.Loc +import Text.Printf + +main :: IO () +main = forever $ do + tks <- streamToList . runLexer luaLexer "stdin" <$> getLine + putStr "[ " + mapM_ (\(L loc tk) -> printf "%s @ %s, " (show tk) (show loc)) tks + putStrLn "]" diff --git a/app/Parse.hs b/app/Parse.hs new file mode 100644 --- /dev/null +++ b/app/Parse.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Language.Lua.Parser + +import Control.Monad +import Options.Applicative +import Text.PrettyPrint.Leijen (Pretty(..), displayS, renderPretty) + +data GrammarMode = ChunkMode | StatementMode | ExpressionMode + deriving Show + +data Opts = Opts + { optsInteractive :: GrammarMode + , optsPretty :: Bool + , optsFile :: Maybe FilePath + } deriving Show + +main :: IO () +main = execParser opts >>= main' + where + opts = info (helper <*> p) + ( fullDesc + <> progDesc "Parse a lua file, or parse interactively" + <> header "Lua parser") + + p :: Parser Opts + p = Opts + <$> (mode <|> pure ExpressionMode) + <*> switch + ( long "pretty" + <> help "Pretty-print output") + <*> optional (strArgument + ( metavar "FILE" + <> help "Lua file to parse")) + + mode :: Parser GrammarMode + mode = ChunkMode <$ switch (long "chunk") + <|> StatementMode <$ switch (long "statement") + <|> ExpressionMode <$ switch (long "expression") + +main' :: Opts -> IO () +main' Opts{..} = + case optsFile of + Just file -> readFile file >>= go luaChunk file + Nothing -> + case optsInteractive of + ChunkMode -> forever $ getLine >>= go luaChunk "" + StatementMode -> forever $ getLine >>= go luaStatement "" + ExpressionMode -> forever $ getLine >>= go luaExpression "" + where + go :: (Show (f NodeInfo), Pretty (f NodeInfo)) => LuaGrammar f -> String -> String -> IO () + go g filename contents = do + let x = parseLuaWith g filename contents + if optsPretty + then putStrLn $ displayS (renderPretty 1.0 80 (pretty x)) "" + else print x diff --git a/language-lua2.cabal b/language-lua2.cabal new file mode 100644 --- /dev/null +++ b/language-lua2.cabal @@ -0,0 +1,104 @@ +name: language-lua2 +version: 0.1.0.0 +synopsis: Lua parser and pretty printer +description: Lua parser and pretty printer +homepage: http://github.com/mitchellwrosen/language-lua2 +license: BSD3 +license-file: LICENSE +author: Mitchell Rosen +maintainer: mitchellwrosen@gmail.com +category: Language +build-type: Simple +cabal-version: >=1.10 + +Flag exes + Description: "Build debug executables" + Default: False + +library + hs-source-dirs: src + exposed-modules: Language.Lua.Lexer + , Language.Lua.Parser + , Language.Lua.Pretty + , Language.Lua.Syntax + , Language.Lua.Token + other-modules: Language.Lua.Internal + build-depends: base >= 4.7 && < 5 + , containers + , Earley + , lexer-applicative + , microlens + , regex-applicative + , semigroups + , srcloc + , transformers + , unordered-containers + , wl-pprint + default-language: Haskell2010 + default-extensions: BangPatterns + , DeriveDataTypeable + , DeriveFunctor + , DeriveGeneric + , ExistentialQuantification + , FlexibleInstances + , OverloadedLists + , OverloadedStrings + , ScopedTypeVariables + , StandaloneDeriving + , RankNTypes + , RecursiveDo + , TupleSections + , ViewPatterns + ghc-options: -Wall + +executable parse + if !flag(exes) + buildable: False + + hs-source-dirs: app + main-is: Parse.hs + build-depends: base + , Earley + , lexer-applicative + , language-lua2 + , optparse-applicative + , srcloc + , wl-pprint + default-language: Haskell2010 + ghc-options: -Wall + +executable lex + if !flag(exes) + buildable: False + + hs-source-dirs: app + main-is: Lex.hs + build-depends: base + , lexer-applicative + , language-lua2 + , srcloc + default-language: Haskell2010 + ghc-options: -Wall + +test-suite language-lua2-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Instances + build-depends: base + , lexer-applicative + , language-lua2 + , QuickCheck + , semigroups + , srcloc + , tasty + , tasty-hunit + , tasty-quickcheck + , unordered-containers + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-extensions: FlexibleInstances + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/mitchellwrosen/language-lua2 diff --git a/src/Language/Lua/Internal.hs b/src/Language/Lua/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lua/Internal.hs @@ -0,0 +1,5 @@ +module Language.Lua.Internal where + +infixl 4 <$$> +(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +(<$$>) = fmap . fmap diff --git a/src/Language/Lua/Lexer.hs b/src/Language/Lua/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lua/Lexer.hs @@ -0,0 +1,278 @@ +module Language.Lua.Lexer + ( luaLexer + + -- * re-exports + , LexicalError(..) + , TokenStream(..) + , runLexer + , streamToList + , streamToEitherList + ) where + +import Language.Lua.Token + +import Data.Char (chr, isDigit, isHexDigit, isSpace) +import Data.List (foldl') +import Data.Maybe (fromMaybe) +import Data.Monoid +import Language.Lexer.Applicative +import Numeric (readHex) +import Text.Regex.Applicative + +-- | +-- @ +-- lex :: String -> [L Token] +-- lex = 'streamToList' . 'runLexer' 'luaLexer' "" +-- @ +-- +-- >>> lex "5+5" +-- [TkIntLit "5",TkPlus,TkIntLit "5"] +-- >>> lex "foo?" +-- [TkIdent "foo"*** Exception: Lexical error at :1:4 +luaLexer :: Lexer Token +luaLexer = luaTokens <> luaWhitespace + +luaTokens :: Lexer Token +luaTokens = token (longest luaToken) + <> token (longestShortest luaLongBracketStringLitPrefix luaLongBracketStringLitSuffix) + +luaToken :: RE Char Token +luaToken = + TkAnd <$ "and" + <|> TkBreak <$ "break" + <|> TkDo <$ "do" + <|> TkElse <$ "else" + <|> TkElseif <$ "elseif" + <|> TkEnd <$ "end" + <|> TkFalse <$ "false" + <|> TkFor <$ "for" + <|> TkFunction <$ "function" + <|> TkGoto <$ "goto" + <|> TkIf <$ "if" + <|> TkIn <$ "in" + <|> TkLocal <$ "local" + <|> TkNil <$ "nil" + <|> TkNot <$ "not" + <|> TkOr <$ "or" + <|> TkRepeat <$ "repeat" + <|> TkReturn <$ "return" + <|> TkThen <$ "then" + <|> TkTrue <$ "true" + <|> TkUntil <$ "until" + <|> TkWhile <$ "while" + <|> TkAssign <$ "=" + <|> TkNeq <$ "~=" + <|> TkPlus <$ "+" + <|> TkDash <$ "-" + <|> TkMult <$ "*" + <|> TkFloatDiv <$ "/" + <|> TkModulo <$ "%" + <|> TkExponent <$ "^" + <|> TkLength <$ "#" + <|> TkBitwiseAnd <$ "&" + <|> TkBitwiseOr <$ "|" + <|> TkLt <$ "<" + <|> TkGt <$ ">" + <|> TkLShift <$ "<<" + <|> TkRShift <$ ">>" + <|> TkFloorDiv <$ "//" + <|> TkEq <$ "==" + <|> TkLeq <$ "<=" + <|> TkGeq <$ ">=" + <|> TkLParen <$ "(" + <|> TkRParen <$ ")" + <|> TkLBrace <$ "{" + <|> TkRBrace <$ "}" + <|> TkLBracket <$ "[" + <|> TkRBracket <$ "]" + <|> TkSemi <$ ";" + <|> TkColon <$ ":" + <|> TkComma <$ "," + <|> TkLabel <$ "::" + <|> TkDot <$ "." + <|> TkConcat <$ ".." + <|> TkVararg <$ "..." + <|> TkTilde <$ "~" + <|> TkQuote <$ "'" + <|> TkDoubleQuote <$ "\"" + <|> TkIdent <$> luaIdentifier + <|> TkStringLit <$> luaStringLit + <|> TkFloatLit <$> luaFloatLit + <|> TkIntLit <$> luaIntLit + +luaIdentifier :: RE Char String +luaIdentifier = (:) + <$> psym identFirst + <*> many (psym identRest) + where + identFirst :: Char -> Bool + identFirst = (||) <$> (== '_') <*> isAlpha + + identRest :: Char -> Bool + identRest = (||) <$> identFirst <*> isDigit + +luaStringLit :: RE Char String +luaStringLit = singleQuoted <|> doubleQuoted + where + singleQuoted :: RE Char String + singleQuoted = quoted '\'' + + doubleQuoted :: RE Char String + doubleQuoted = quoted '\"' + + quoted :: Char -> RE Char String + quoted c = between c c $ many (escapeSequence <|> not_c) + where + not_c :: RE Char Char + not_c = psym (/= c) + + escapeSequence :: RE Char Char + escapeSequence = sym '\\' *> sequences + where + sequences :: RE Char Char + sequences = + '\a' <$ sym 'a' + <|> '\b' <$ sym 'b' + <|> '\f' <$ sym 'f' + <|> '\n' <$ sym 'n' + <|> '\r' <$ sym 'r' + <|> '\t' <$ sym 't' + <|> '\v' <$ sym 'v' + <|> sym '\\' + <|> sym '"' + <|> sym '\'' + <|> sym '\n' + <|> hexEscape + <|> decimalEscape + -- TODO: unicode escape + -- TODO: \z + where + hexEscape :: RE Char Char + hexEscape = go <$> (sym 'x' *> hexDigit) <*> hexDigit + where + go :: Char -> Char -> Char + go x y = let [(n,"")] = readHex [x,y] in chr n + + decimalEscape :: RE Char Char + decimalEscape = chr . read <$> betweenN 1 3 digit + + -- unicodeEscape :: RE Char String + -- unicodeEscape = (\a b c -> a ++ b ++ [c]) + -- <$> "u{" + -- <*> some hexDigit + -- <*> sym '}' + +luaIntLit :: RE Char String +luaIntLit = hexLit <|> some digit + where + hexLit :: RE Char String + hexLit = (\a b c -> a:b:c) + <$> sym '0' + <*> oneOf "xX" + <*> some hexDigit + +luaFloatLit :: RE Char String +luaFloatLit = hexLit <|> decimalLit + where + hexLit :: RE Char String + hexLit = (\a b cs ds -> a : b : cs ++ ds) + <$> sym '0' + <*> oneOf "xX" + <*> some hexDigit + <*> andOr (fractionalSuffix hexDigit) (exponentPart "pP") + + decimalLit :: RE Char String + decimalLit = (++) <$> some digit <*> andOr (fractionalSuffix digit) (exponentPart "eE") + + exponentPart :: String -> RE Char String + exponentPart cs = f + <$> oneOf cs + <*> optional (oneOf "-+") + <*> some digit -- Yes, digit, even for binaryExponent: 0x0p+A is invalid + where + f :: Char -> Maybe Char -> String -> String + f x Nothing zs = x:zs + f x (Just y) zs = x:y:zs + + fractionalSuffix :: RE Char Char -> RE Char String + fractionalSuffix c = (:) <$> sym '.' <*> many c + +luaLongBracketStringLitPrefix :: RE Char String +luaLongBracketStringLitPrefix = between '[' '[' (many (sym '=')) + +luaLongBracketStringLitSuffix :: String -> RE Char Token +luaLongBracketStringLitSuffix eqs = TkStringLit <$> + -- "For convenience, when the opening long bracket is immediately followed + -- by a newline, the newline is not included in the string." + (optional (sym '\n') *> many anySym <* between ']' ']' (exactlyN (length eqs) (sym '='))) + +luaWhitespace :: Lexer Token +luaWhitespace = mconcat + [ whitespace $ longest (psym isSpace) + , whitespace $ longestShortest luaBlockCommentPrefix luaBlockCommentSuffix + , whitespace $ longest luaLineComment + ] + +luaBlockCommentPrefix :: RE Char String +luaBlockCommentPrefix = "--[" *> many (sym '=') <* sym '[' + +luaBlockCommentSuffix :: String -> RE Char Char +luaBlockCommentSuffix xs = many anySym *> "--]" *> exactlyN (length xs) (sym '=') *> sym ']' + +luaLineComment :: RE Char String +luaLineComment = "--" *> many (psym (/= '\n')) + +-------------------------------------------------------------------------------- +-- Regex extras + +oneOf :: Eq s => [s] -> RE s s +oneOf = foldl' (\acc x -> acc <|> sym x) empty + +-- `andOr f x y` will succeed on `x`, `y`, and `xy` +andOr :: forall m. Monoid m => RE Char m -> RE Char m -> RE Char m +andOr rx ry = ry <|> liftA2 (\x my -> x <> fromMaybe mempty my) rx (optional ry) + +between :: Char -> Char -> RE Char a -> RE Char a +between x y z = sym x *> z <* sym y + +hexDigit :: RE Char Char +hexDigit = psym isHexDigit + +digit :: RE Char Char +digit = psym isDigit + +-------------------------------------------------------------------------------- +-- Char extras + +isAlpha :: Char -> Bool +isAlpha = (||) <$> isLowercase <*> isUppercase + +isLowercase :: Char -> Bool +isLowercase = charBetween 'a' 'z' + +isUppercase :: Char -> Bool +isUppercase = charBetween 'A' 'Z' + +charBetween :: Char -> Char -> Char -> Bool +charBetween x y = (&&) <$> (>= x) <*> (<= y) + +-------------------------------------------------------------------------------- +-- Applicative/Alternative extras + +exactlyN :: Alternative f => Int -> f a -> f [a] +exactlyN 0 _ = pure [] +exactlyN 1 f = pure <$> f +exactlyN n f = (:) <$> f <*> exactlyN (n-1) f + +-- Inclusive +betweenN :: Alternative f => Int -> Int -> f a -> f [a] +betweenN x y _ | x > y = error "betweenN: x > y" +betweenN 0 y f = upToN y f +betweenN x y f = liftA2 (++) (exactlyN x f) (upToN (y-x) f) + +-- Inclusive +upToN :: Alternative f => Int -> f a -> f [a] +upToN 0 _ = pure [] +upToN 1 f = fmap pure f <|> pure [] +upToN n f = let g = upToN (n-1) f + in liftA2 (:) f g <|> g diff --git a/src/Language/Lua/Parser.hs b/src/Language/Lua/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lua/Parser.hs @@ -0,0 +1,905 @@ +module Language.Lua.Parser + ( -- * Lua parsers + parseLua + , parseLuaWith + , LuaParseException(..) + + -- * Lua grammars + , LuaGrammar + , luaChunk + , luaStatement + , luaExpression + , NodeInfo(..) + , nodeLoc + , nodeTokens + + -- * re-exports + -- | These are provided if you want more control over parsing than what + -- 'parseLua' or 'parseLuaWith' provides. + , Report(..) + , Result(..) + , allParses + , fullParses + , parser + , report + ) where + +import Language.Lua.Internal +import Language.Lua.Lexer +import Language.Lua.Syntax +import Language.Lua.Token + +import Control.Applicative +import Control.Exception (Exception, mapException, throw) +import Data.Data +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NE +import Data.Loc +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Sequence (Seq) +import GHC.Generics (Generic) +import Lens.Micro +import Prelude hiding (break, repeat, until) +import Text.Earley +import Text.Earley.Mixfix +import Text.Printf (printf) + +-- | AST node source location and constituent tokens. The tokens are provided +-- for style-checking purposes; with them, you may assert proper whitespace +-- protocol, alignment, trailing commas on table constructors, and whatever +-- other subjectivities. +data NodeInfo = NodeInfo + { _nodeLoc :: !Loc -- ^ Source location; spans the entirety of the node. + , _nodeTokens :: !(Seq (L Token)) -- ^ Parsed tokens involved in node production. + } deriving (Data, Eq, Generic, Show, Typeable) + +instance Monoid NodeInfo where + mempty = NodeInfo mempty mempty + mappend (NodeInfo x1 y1) (NodeInfo x2 y2) = NodeInfo (x1 <> x2) (y1 <> y2) + +nodeLoc :: Lens' NodeInfo Loc +nodeLoc = lens (\(NodeInfo a _) -> a) (\(NodeInfo _ b) a -> NodeInfo a b) + +nodeTokens :: Lens' NodeInfo (Seq (L Token)) +nodeTokens = lens (\(NodeInfo _ b) -> b) (\(NodeInfo a _) b -> NodeInfo a b) + +class HasNodeInfo a where + nodeInfo :: a -> NodeInfo + +instance HasNodeInfo NodeInfo where + nodeInfo = id + +instance HasNodeInfo (L Token) where + nodeInfo tk = NodeInfo (locOf tk) [tk] + +instance Annotated ast => HasNodeInfo (ast NodeInfo) where + nodeInfo = (^. ann) + +instance (HasNodeInfo a, HasNodeInfo b) => HasNodeInfo (a, b) where + nodeInfo (a, b) = nodeInfo a <> nodeInfo b + +instance (HasNodeInfo a, HasNodeInfo b, HasNodeInfo c) => HasNodeInfo (a, b, c) where + nodeInfo (a, b, c) = nodeInfo a <> nodeInfo b <> nodeInfo c + +instance (HasNodeInfo a, HasNodeInfo b, HasNodeInfo c, HasNodeInfo d) => HasNodeInfo (a, b, c, d) where + nodeInfo (a, b, c, d) = nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d + +-- Make explicit instances for these Foldable containers to avoid overlapping instances. + +instance HasNodeInfo a => HasNodeInfo [a] where + nodeInfo = foldMap nodeInfo + +instance HasNodeInfo a => HasNodeInfo (Seq a) where + nodeInfo = foldMap nodeInfo + +instance HasNodeInfo a => HasNodeInfo (NonEmpty a) where + nodeInfo = foldMap nodeInfo + +instance HasNodeInfo a => HasNodeInfo (Maybe a) where + nodeInfo = foldMap nodeInfo + +type LuaGrammar f = forall r. Grammar r String (Prod r String (L Token) (f NodeInfo)) + +data LuaParseException + = LuaLexException !Pos + | LuaParseException !FilePath !(Report String [L Token]) + | LuaAmbiguousParseException !FilePath !(Report String [L Token]) + deriving (Eq, Typeable) + +instance Show LuaParseException where + show e = + case e of + LuaLexException pos -> "Unexpected token at " ++ displayPos pos + LuaParseException filename r -> + case r of + Report _ xs [] -> unlines + [ filename ++ ":" + , " Expected one of: " ++ intercalate ", " xs + , " But found: " + ] + Report _ xs (L (Loc p _) tk : _) -> unlines + [ displayPos p ++ ":" + , " Expected one of: " ++ intercalate ", " xs + , " But found: '" ++ showToken tk ++ "'" + ] + LuaAmbiguousParseException filename r -> + let s = "Ambiguous parse. See for a likely explanation.\n" + in case r of + Report _ xs [] -> unlines + [ filename ++ ":" + , " " ++ s + , " Expected one of: " ++ intercalate ", " xs + , " But found: " + ] + Report _ xs (L (Loc p _) tk : _) -> unlines + [ displayPos p ++ ":" + , " " ++ s + , " Expected one of: " ++ intercalate ", " xs + , " But found: '" ++ showToken tk ++ "'" + ] + +instance Exception LuaParseException + +-- | Parse a Lua file. May throw 'LuaParseException'. +-- +-- @ +-- 'parseLua' = 'parseLuaWith' 'luaChunk' +-- @ +parseLua + :: String -- ^ Source filename (used in locations). + -> String -- ^ Source contents. + -> Chunk NodeInfo +parseLua = parseLuaWith luaChunk + +-- | Parse Lua code with the given grammar. May throw 'LuaParseException'. +-- +-- >>> parseLuaWith luaExprssion "" "5+5" +-- Binop +-- (NodeInfo +-- { nodeLoc = Loc (Pos "" 1 1 0) (Pos "" 1 3 2) +-- , nodeTokens = fromList [TkIntLit "5",TkPlus,TkIntLit "5"] +-- }) +-- (Plus +-- (NodeInfo +-- { nodeLoc = Loc (Pos "" 1 2 1) (Pos "" 1 2 1) +-- , nodeTokens = fromList [TkPlus] +-- })) +-- (Integer +-- (NodeInfo +-- { nodeLoc = Loc (Pos "" 1 1 0) (Pos "" 1 1 0) +-- , nodeTokens = fromList [TkIntLit "5"] +-- }) +-- "5") +-- (Integer +-- (NodeInfo +-- { nodeLoc = Loc (Pos "" 1 3 2) (Pos "" 1 3 2) +-- , nodeTokens = fromList [TkIntLit "5"] +-- }) +-- "5") +-- +-- All AST nodes are 'Functor's over their annotation: +-- +-- >>> (() <$) <$> parseLuaWith luaExpression "" "5+5" +-- Binop () (Plus ()) (Integer () "5") (Integer () "5") +parseLuaWith + :: LuaGrammar f -- ^ Grammar to parse with. + -> String -- ^ Source filename (used in locations). + -> String -- ^ Source contents. + -> f NodeInfo +parseLuaWith g filename contents = + let tokens = streamToList' (runLexer luaLexer filename contents) + in case fullParses (parser g tokens) of + ([x], _) -> x + ([], r) -> throw (LuaParseException filename r) + (_, r) -> throw (LuaAmbiguousParseException filename r) + where + -- Wrap a LexicalError in our own LuaParseException. + streamToList' :: forall tok. TokenStream tok -> [tok] + streamToList' = go . streamToList + where + go :: [tok] -> [tok] + go ts = case mapException f ts of + [] -> [] + (t:ts') -> t : go ts' + + f :: LexicalError -> LuaParseException + f (LexicalError pos) = LuaLexException pos + +-- | Grammar for a Lua chunk; i.e. a Lua compilation unit, defined as a list of +-- statements. This is the grammar you should use to parse real Lua code. +luaChunk :: LuaGrammar Chunk -- Grammar r String (Prod r String (L Token) (Block NodeInfo)) +luaChunk = (\(a,_,_) -> a) <$> grammar + +-- | Grammar for a single Lua statement. Mostly subsumed by 'luaChunk'. +luaStatement :: LuaGrammar Statement +luaStatement = (\(_,b,_) -> b) <$> grammar + +-- | Grammar for a Lua expression. Provided for smaller REPL-like parsing that +-- operates only on expressions. +luaExpression :: LuaGrammar Expression +luaExpression = (\(_,_,c) -> c) <$> grammar + +grammar :: Grammar r String ( Prod r String (L Token) (Block NodeInfo) + , Prod r String (L Token) (Statement NodeInfo) + , Prod r String (L Token) (Expression NodeInfo) + ) +grammar = mdo + block :: Prod r String (L Token) (Block NodeInfo) <- rule $ + mkBlock + <$> many statement + <*> optional returnStatement + + statement :: Prod r String (L Token) (Statement NodeInfo) <- rule $ + mkEmptyStmt + <$> semi + <|> mkAssign + <$> varList1 + <*> assign + <*> expressionList1 + <|> mkFunCall + <$> functionCall + <|> mkLabel + <$> label + <*> ident + <*> label + <|> mkBreak + <$> break + <|> mkGoto + <$> goto + <*> ident + <|> mkDo + <$> do' + <*> block + <*> end + <|> mkWhile + <$> while + <*> expression + <*> do' + <*> block + <*> end + <|> mkRepeat + <$> repeat + <*> block + <*> until + <*> expression + <|> mkIf + <$> if' + <*> expression + <*> then' + <*> block + <*> many ((,,,) + <$> elseif + <*> expression + <*> then' + <*> block) + <*> optional ((,) + <$> else' + <*> block) + <*> end + <|> mkFor + <$> for + <*> ident + <*> assign + <*> expression + <*> comma + <*> expression + <*> optional ((,) + <$> comma + <*> expression) + <*> do' + <*> block + <*> end + <|> mkForIn + <$> for + <*> identList1 + <*> in' + <*> expressionList1 + <*> do' + <*> block + <*> end + <|> mkFunAssign + <$> function + <*> functionName + <*> functionBody + <|> mkLocalFunAssign + <$> local + <*> function + <*> ident + <*> functionBody + <|> mkLocalAssign + <$> local + <*> identList1 + <*> optional ((,) + <$> assign + <*> expressionList1) + + returnStatement :: Prod r String (L Token) (ReturnStatement NodeInfo) <- rule $ + mkReturnStatement + <$> return' + <*> expressionList + <*> optional semi + + functionName :: Prod r String (L Token) (FunctionName NodeInfo) <- rule $ + mkFunctionName + <$> identSepByDot + <*> optional ((,) + <$> colon + <*> ident) + + identSepByDot :: Prod r String (L Token) (IdentList1 NodeInfo) <- + uncurry IdentList1 <$$> sepBy1 ident dot + + varList1 :: Prod r String (L Token) (VariableList1 NodeInfo) <- + uncurry VariableList1 <$$> sepBy1 var comma + + var :: Prod r String (L Token) (Variable NodeInfo) <- rule $ + mkVarIdent + <$> ident + <|> mkVarField + <$> prefixExpression + <*> lbracket + <*> expression + <*> rbracket + <|> mkVarFieldName + <$> prefixExpression + <*> dot + <*> ident + + identList :: Prod r String (L Token) (IdentList NodeInfo) <- + uncurry IdentList <$$> sepBy ident comma + + identList1 :: Prod r String (L Token) (IdentList1 NodeInfo) <- + uncurry IdentList1 <$$> sepBy1 ident comma + + expressionList :: Prod r String (L Token) (ExpressionList NodeInfo) <- + uncurry ExpressionList <$$> sepBy expression comma + + expressionList1 :: Prod r String (L Token) (ExpressionList1 NodeInfo) <- + uncurry ExpressionList1 <$$> sepBy1 expression comma + + expression :: Prod r String (L Token) (Expression NodeInfo) <- + mixfixExpression expressionTable atomicExpression combineMixfix + + atomicExpression :: Prod r String (L Token) (Expression NodeInfo) <- rule $ + mkNil <$> nil + <|> mkBool True <$> true + <|> mkBool False <$> false + <|> mkInteger <$> intLit + <|> mkFloat <$> floatLit + <|> mkString <$> stringLit + <|> mkVararg <$> vararg + <|> mkPrefixExp <$> prefixExpression + <|> mkTableCtor <$> tableConstructor + + prefixExpression :: Prod r String (L Token) (PrefixExpression NodeInfo) <- rule $ + mkPrefixVar + <$> var + <|> mkPrefixFunCall + <$> functionCall + <|> mkParens + <$> lparen + <*> expression + <*> rparen + + functionCall :: Prod r String (L Token) (FunctionCall NodeInfo) <- rule $ + mkFunctionCall + <$> prefixExpression + <*> optional ((,) + <$> colon + <*> ident) + <*> functionArgs + + functionArgs :: Prod r String (L Token) (FunctionArgs NodeInfo) <- rule $ + mkArgs + <$> lparen + <*> expressionList + <*> rparen + <|> mkArgsTable + <$> tableConstructor + <|> mkArgsString + <$> stringLit + + functionBody :: Prod r String (L Token) (FunctionBody NodeInfo) <- rule $ + mkFunctionBody + <$> lparen + <*> identList + <*> optional ((,) + <$> comma + <*> vararg) + <*> rparen + <*> block + <*> end + + tableConstructor :: Prod r String (L Token) (TableConstructor NodeInfo) <- rule $ + mkTableConstructor + <$> lbrace + <*> optional fieldList + <*> rbrace + + field :: Prod r String (L Token) (Field NodeInfo) <- rule $ + mkFieldExp + <$> lbracket + <*> expression + <*> rbracket + <*> assign + <*> expression + <|> mkFieldIdent + <$> ident + <*> assign + <*> expression + <|> mkField + <$> expression + + fieldList <- let sep = comma <|> semi in + sepBy1 field sep >>= \fields -> rule (mkFieldList <$> fields <*> optional sep) + + return (block, statement, expression) + where + -- http://www.lua.org/manual/5.3/manual.html#3.4.8 + expressionTable :: [[([Maybe (Prod r String (L Token) (L Token))], Associativity)]] + expressionTable = + [ [ (binop TkOr "'or'", LeftAssoc) ] + + , [ (binop TkAnd "'and'", LeftAssoc) ] + + , [ (binop TkLt "'<'", LeftAssoc) + , (binop TkGt "'>'", LeftAssoc) + , (binop TkLeq "'<='", LeftAssoc) + , (binop TkGeq "'>='", LeftAssoc) + , (binop TkNeq "'~='", LeftAssoc) + , (binop TkEq "'=='", LeftAssoc) ] + + , [ (binop TkBitwiseOr "'|'", LeftAssoc) ] + + , [ (binop TkTilde "'~'", LeftAssoc) ] + + , [ (binop TkBitwiseAnd "'&'", LeftAssoc) ] + + , [ (binop TkLShift "'<<'", LeftAssoc) + , (binop TkRShift "'>>'", LeftAssoc) ] + + , [ (binop TkConcat "'..'", RightAssoc) ] + + , [ (binop TkPlus "'+'", LeftAssoc) + , (binop TkDash "'-'", LeftAssoc) ] + + , [ (binop TkMult "'*'", LeftAssoc) + , (binop TkFloatDiv "'/'", LeftAssoc) + , (binop TkFloorDiv "'//'", LeftAssoc) + , (binop TkModulo "'%'", LeftAssoc) ] + + , [ unop TkNot "'not'" + , unop TkLength "'#'" + , unop TkDash "'-'" + , unop TkTilde "'~'" ] + + , [ (binop TkExponent "'^'", RightAssoc) ] + ] + where + binop :: Token -> String -> [Maybe (Prod r String (L Token) (L Token))] + binop tk s = [Nothing, Just (locSymbol tk s), Nothing] + + unop :: Token -> String -> ([Maybe (Prod r String (L Token) (L Token))], Associativity) + unop tk s = ([Just (locSymbol tk s), Nothing], RightAssoc) + + combineMixfix :: [Maybe (L Token)] -> [Expression NodeInfo] -> Expression NodeInfo + combineMixfix (viewBinop -> Just tk) [e1, e2] = Binop (nodeInfo e1 <> nodeInfo tk <> nodeInfo e2) (tk2binop tk) e1 e2 + combineMixfix (viewUnop -> Just tk) [e] = Unop (nodeInfo tk <> nodeInfo e) (tk2unop tk) e + combineMixfix xs ys = error $ printf "Whoops, parser is busted.\nHoles: %s\nExprs: %s\n" (show xs) (show ys) + + viewBinop :: [Maybe (L Token)] -> Maybe (L Token) + viewBinop [Nothing, x@(Just _), Nothing] = x + viewBinop _ = Nothing + + viewUnop :: [Maybe (L Token)] -> Maybe (L Token) + viewUnop [x@(Just _), Nothing] = x + viewUnop _ = Nothing + + tk2binop :: L Token -> Binop NodeInfo + tk2binop tk@(L _ TkPlus) = Plus (nodeInfo tk) + tk2binop tk@(L _ TkDash) = Minus (nodeInfo tk) + tk2binop tk@(L _ TkMult) = Mult (nodeInfo tk) + tk2binop tk@(L _ TkFloatDiv) = FloatDiv (nodeInfo tk) + tk2binop tk@(L _ TkFloorDiv) = FloorDiv (nodeInfo tk) + tk2binop tk@(L _ TkExponent) = Exponent (nodeInfo tk) + tk2binop tk@(L _ TkModulo) = Modulo (nodeInfo tk) + tk2binop tk@(L _ TkBitwiseAnd) = BitwiseAnd (nodeInfo tk) + tk2binop tk@(L _ TkTilde) = BitwiseXor (nodeInfo tk) + tk2binop tk@(L _ TkBitwiseOr) = BitwiseOr (nodeInfo tk) + tk2binop tk@(L _ TkRShift) = Rshift (nodeInfo tk) + tk2binop tk@(L _ TkLShift) = Lshift (nodeInfo tk) + tk2binop tk@(L _ TkConcat) = Concat (nodeInfo tk) + tk2binop tk@(L _ TkLt) = Lt (nodeInfo tk) + tk2binop tk@(L _ TkLeq) = Leq (nodeInfo tk) + tk2binop tk@(L _ TkGt) = Gt (nodeInfo tk) + tk2binop tk@(L _ TkGeq) = Geq (nodeInfo tk) + tk2binop tk@(L _ TkEq) = Eq (nodeInfo tk) + tk2binop tk@(L _ TkNeq) = Neq (nodeInfo tk) + tk2binop tk@(L _ TkAnd) = And (nodeInfo tk) + tk2binop tk@(L _ TkOr) = Or (nodeInfo tk) + tk2binop (L _ tk) = error $ printf "Token %s does not correspond to a binary op" (show tk) + + tk2unop :: L Token -> Unop NodeInfo + tk2unop tk@(L _ TkNot) = Not (nodeInfo tk) + tk2unop tk@(L _ TkLength) = Length (nodeInfo tk) + tk2unop tk@(L _ TkDash) = Negate (nodeInfo tk) + tk2unop tk@(L _ TkTilde) = BitwiseNot (nodeInfo tk) + tk2unop (L _ tk) = error $ printf "Token %s does not correspond to a unary op" (show tk) + +mkBlock :: [Statement NodeInfo] -> Maybe (ReturnStatement NodeInfo) -> Block NodeInfo +mkBlock a b = Block (nodeInfo a <> nodeInfo b) a b + +mkEmptyStmt :: L Token -> Statement NodeInfo +mkEmptyStmt = EmptyStmt . nodeInfo + +mkAssign :: VariableList1 NodeInfo -> L Token -> ExpressionList1 NodeInfo -> Statement NodeInfo +mkAssign a b c = Assign (nodeInfo a <> nodeInfo b <> nodeInfo c) a c + +mkFunCall :: FunctionCall NodeInfo -> Statement NodeInfo +mkFunCall a = FunCall (nodeInfo a) a + +mkLabel :: L Token -> Ident NodeInfo -> L Token -> Statement NodeInfo +mkLabel a b c = Label (nodeInfo a <> nodeInfo b <> nodeInfo c) b + +mkBreak :: L Token -> Statement NodeInfo +mkBreak = Break . nodeInfo + +mkGoto :: L Token -> Ident NodeInfo -> Statement NodeInfo +mkGoto a b = Goto (nodeInfo a <> nodeInfo b) b + +mkDo :: L Token -> Block NodeInfo -> L Token -> Statement NodeInfo +mkDo a b c = Do (nodeInfo a <> nodeInfo b <> nodeInfo c) (injectLoc a b) + +mkWhile :: L Token -> Expression NodeInfo -> L Token -> Block NodeInfo -> L Token -> Statement NodeInfo +mkWhile a b c d e = While (nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d <> nodeInfo e) b (injectLoc c d) + +mkRepeat :: L Token -> Block NodeInfo -> L Token -> Expression NodeInfo -> Statement NodeInfo +mkRepeat a b c d = Repeat (nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d) (injectLoc a b) d + +mkIf + :: L Token + -> Expression NodeInfo + -> L Token + -> Block NodeInfo + -> [(L Token, Expression NodeInfo, L Token, Block NodeInfo)] + -> Maybe (L Token, Block NodeInfo) + -> L Token + -> Statement NodeInfo +mkIf a b c d e f g = + If (nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d <> nodeInfo e <> nodeInfo f <> nodeInfo g) + ((b, injectLoc c d) :| map (\(_,x,y,z) -> (x, injectLoc y z)) e) + (uncurry injectLoc <$> f) + +mkFor + :: L Token + -> Ident NodeInfo + -> L Token + -> Expression NodeInfo + -> L Token + -> Expression NodeInfo + -> Maybe (L Token, Expression NodeInfo) + -> L Token + -> Block NodeInfo + -> L Token + -> Statement NodeInfo +mkFor a b c d e f g h i j = For ni b d f (snd <$> g) (injectLoc h i) + where + ni :: NodeInfo + ni = nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d <> nodeInfo e <> + nodeInfo f <> nodeInfo g <> nodeInfo h <> nodeInfo i <> nodeInfo j + +mkForIn + :: L Token + -> IdentList1 NodeInfo + -> L Token + -> ExpressionList1 NodeInfo + -> L Token + -> Block NodeInfo + -> L Token + -> Statement NodeInfo +mkForIn a b c d e f g = ForIn ni b d (injectLoc e f) + where + ni :: NodeInfo + ni = nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d <> + nodeInfo e <> nodeInfo f <> nodeInfo g + +mkFunAssign + :: L Token + -> FunctionName NodeInfo + -> FunctionBody NodeInfo + -> Statement NodeInfo +mkFunAssign a b c = FunAssign (nodeInfo a <> nodeInfo b <> nodeInfo c) b c + +mkLocalFunAssign + :: L Token + -> L Token + -> Ident NodeInfo + -> FunctionBody NodeInfo + -> Statement NodeInfo +mkLocalFunAssign a b c d = LocalFunAssign (nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d) c d + +mkLocalAssign + :: L Token + -> IdentList1 NodeInfo + -> Maybe (L Token, ExpressionList1 NodeInfo) + -> Statement NodeInfo +mkLocalAssign a b c = LocalAssign (nodeInfo a <> nodeInfo b <> nodeInfo c) b c' + where + c' :: ExpressionList NodeInfo + c' = maybe (ExpressionList mempty []) + (\(_, ExpressionList1 n es) -> ExpressionList n (NE.toList es)) + c + +mkReturnStatement :: L Token -> ExpressionList NodeInfo -> Maybe (L Token) -> ReturnStatement NodeInfo +mkReturnStatement a b c = ReturnStatement (nodeInfo a <> nodeInfo b <> nodeInfo c) b + +mkFunctionName + :: IdentList1 NodeInfo + -> Maybe (L Token, Ident NodeInfo) + -> FunctionName NodeInfo +mkFunctionName a b = FunctionName (nodeInfo a <> nodeInfo b) a (snd <$> b) + +mkVarIdent :: Ident NodeInfo -> Variable NodeInfo +mkVarIdent a = VarIdent (nodeInfo a) a + +mkVarField :: PrefixExpression NodeInfo -> L Token -> Expression NodeInfo -> L Token -> Variable NodeInfo +mkVarField a b c d = VarField (nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d) a c + +mkVarFieldName :: PrefixExpression NodeInfo -> L Token -> Ident NodeInfo -> Variable NodeInfo +mkVarFieldName a b c = VarFieldName (nodeInfo a <> nodeInfo b <> nodeInfo c) a c + +mkNil :: L Token -> Expression NodeInfo +mkNil = Nil . nodeInfo + +mkBool :: Bool -> L Token -> Expression NodeInfo +mkBool a b = Bool (nodeInfo b) a + +mkInteger :: L Token -> Expression NodeInfo +mkInteger a@(L _ (TkIntLit s)) = Integer (nodeInfo a) s +mkInteger (L _ tk) = error $ printf "mkInteger: %s is not a TkIntLit" (show tk) + +mkFloat :: L Token -> Expression NodeInfo +mkFloat a@(L _ (TkFloatLit s)) = Float (nodeInfo a) s +mkFloat (L _ tk) = error $ printf "mkFloat: %s is not a TkFloatLit" (show tk) + +mkString :: L Token -> Expression NodeInfo +mkString a@(L _ (TkStringLit s)) = String (nodeInfo a) s +mkString (L _ tk) = error $ printf "mkString: %s is not a TkStringLit" (show tk) + +mkVararg :: L Token -> Expression NodeInfo +mkVararg = Vararg . nodeInfo + +mkPrefixExp :: PrefixExpression NodeInfo -> Expression NodeInfo +mkPrefixExp a = PrefixExp (nodeInfo a) a + +mkTableCtor :: TableConstructor NodeInfo -> Expression NodeInfo +mkTableCtor a = TableCtor (nodeInfo a) a + +mkPrefixVar :: Variable NodeInfo -> PrefixExpression NodeInfo +mkPrefixVar a = PrefixVar (nodeInfo a) a + +mkPrefixFunCall :: FunctionCall NodeInfo -> PrefixExpression NodeInfo +mkPrefixFunCall a = PrefixFunCall (nodeInfo a) a + +mkParens :: L Token -> Expression NodeInfo -> L Token -> PrefixExpression NodeInfo +mkParens a b c = Parens (nodeInfo a <> nodeInfo b <> nodeInfo c) b + +mkFunctionCall + :: PrefixExpression NodeInfo + -> Maybe (L Token, Ident NodeInfo) + -> FunctionArgs NodeInfo + -> FunctionCall NodeInfo +mkFunctionCall a (Just (b,c)) d = MethodCall (nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d) a c d +mkFunctionCall a Nothing b = FunctionCall (nodeInfo a <> nodeInfo b) a b + +mkArgs :: L Token -> ExpressionList NodeInfo -> L Token -> FunctionArgs NodeInfo +mkArgs a b c = Args (nodeInfo a <> nodeInfo b <> nodeInfo c) b + +mkArgsTable :: TableConstructor NodeInfo -> FunctionArgs NodeInfo +mkArgsTable a = ArgsTable (nodeInfo a) a + +mkArgsString :: L Token -> FunctionArgs NodeInfo +mkArgsString a@(L _ (TkStringLit s)) = ArgsString (nodeInfo a) s +mkArgsString tk = error $ printf "mkArgsString: %s is not a TkStringLit" (show tk) + +mkFunctionBody + :: L Token + -> IdentList NodeInfo + -> Maybe (L Token, L Token) + -> L Token + -> Block NodeInfo + -> L Token + -> FunctionBody NodeInfo +mkFunctionBody a b (Just (c,d)) e f g = FunctionBody ni b True (injectLoc e f) + where + ni = nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d <> + nodeInfo e <> nodeInfo f <> nodeInfo g +mkFunctionBody a b Nothing c d e = FunctionBody ni b False (injectLoc c d) + where + ni = nodeInfo a <> nodeInfo b <> nodeInfo c <> + nodeInfo d <> nodeInfo e + +mkTableConstructor :: L Token -> Maybe (FieldList NodeInfo) -> L Token -> TableConstructor NodeInfo +mkTableConstructor a b c = TableConstructor (nodeInfo a <> nodeInfo b <> nodeInfo c) (fromMaybe (FieldList mempty []) b) + +mkFieldExp :: L Token -> Expression NodeInfo -> L Token -> L Token -> Expression NodeInfo -> Field NodeInfo +mkFieldExp a b c d e = FieldExp (nodeInfo a <> nodeInfo b <> nodeInfo c <> nodeInfo d <> nodeInfo e) b e + +mkFieldIdent :: Ident NodeInfo -> L Token -> Expression NodeInfo -> Field NodeInfo +mkFieldIdent a b c = FieldIdent (nodeInfo a <> nodeInfo b <> nodeInfo c) a c + +mkField :: Expression NodeInfo -> Field NodeInfo +mkField a = Field (nodeInfo a) a + +mkFieldList :: (NodeInfo, NonEmpty (Field NodeInfo)) -> Maybe (L Token) -> FieldList NodeInfo +mkFieldList a b = FieldList (nodeInfo a <> nodeInfo b) (NE.toList (snd a)) + +-- Inspect a block to see if it contains a location or not; if not (i.e. it's +-- completely empty, as in "do end", we simply set its location to where it +-- would have been (the end of the preceding token). This is so a client can +-- report the location of an empty block as a warning, if they so desire. +injectLoc :: L Token -> Block NodeInfo -> Block NodeInfo +injectLoc a b = + case b^.ann.nodeLoc of + NoLoc -> b & ann.nodeLoc .~ locEnd (locOf a) + _ -> b + +-------------------------------------------------------------------------------- +-- Combinators + +sepBy :: (HasNodeInfo a, HasNodeInfo sep) + => Prod r e t a + -> Prod r e t sep + -> Grammar r e (Prod r e t (NodeInfo, [a])) +sepBy f sep = do + fs <- sepBy1 f sep + rule $ (_2 %~ NE.toList) <$> fs + <|> pure mempty + +sepBy1 :: forall r e t a sep. (HasNodeInfo a, HasNodeInfo sep) + => Prod r e t a + -> Prod r e t sep + -> Grammar r e (Prod r e t (NodeInfo, NonEmpty a)) +sepBy1 f sep = mdo + fs :: Prod r e t (NodeInfo, [a]) <- + rule $ liftA3 (\a b (c,d) -> (nodeInfo a <> nodeInfo b <> c, b:d)) sep f fs + <|> pure mempty + rule $ liftA2 (\a (b,c) -> (nodeInfo a <> b, a :| c)) f fs + +-------------------------------------------------------------------------------- +-- Token productions + +break :: Prod r String (L Token) (L Token) +break = locSymbol TkBreak "'break'" + +colon :: Prod r String (L Token) (L Token) +colon = locSymbol TkColon "':'" + +comma :: Prod r String (L Token) (L Token) +comma = locSymbol TkComma "','" + +do' :: Prod r String (L Token) (L Token) +do' = locSymbol TkDo "'do'" + +dot :: Prod r String (L Token) (L Token) +dot = locSymbol TkDot "'.'" + +label :: Prod r String (L Token) (L Token) +label = locSymbol TkLabel "'::'" + +else' :: Prod r String (L Token) (L Token) +else' = locSymbol TkElse "'else'" + +elseif :: Prod r String (L Token) (L Token) +elseif = locSymbol TkElseif "'elseif'" + +end :: Prod r String (L Token) (L Token) +end = locSymbol TkEnd "'end'" + +assign :: Prod r String (L Token) (L Token) +assign = locSymbol TkAssign "'='" + +false :: Prod r String (L Token) (L Token) +false = locSymbol TkFalse "'false'" + +floatLit :: Prod r String (L Token) (L Token) +floatLit = locSatisfy isFloatLit "float" + where + isFloatLit :: Token -> Bool + isFloatLit (TkFloatLit _) = True + isFloatLit _ = False + +for :: Prod r String (L Token) (L Token) +for = locSymbol TkFor "'for'" + +function :: Prod r String (L Token) (L Token) +function = locSymbol TkFunction "'function'" + +goto :: Prod r String (L Token) (L Token) +goto = locSymbol TkGoto "'goto'" + +ident :: Prod r String (L Token) (Ident NodeInfo) +ident = (\tk@(L _ (TkIdent s)) -> Ident (nodeInfo tk) s) <$> locSatisfy isIdent "'ident'" + where + isIdent :: Token -> Bool + isIdent (TkIdent _) = True + isIdent _ = False + +if' :: Prod r String (L Token) (L Token) +if' = locSymbol TkIf "'if'" + +in' :: Prod r String (L Token) (L Token) +in' = locSymbol TkIn "'in'" + +intLit :: Prod r String (L Token) (L Token) +intLit = locSatisfy isIntLit "integer" + where + isIntLit :: Token -> Bool + isIntLit (TkIntLit _) = True + isIntLit _ = False + +lbrace :: Prod r String (L Token) (L Token) +lbrace = locSymbol TkLBrace "'{'" + +lbracket :: Prod r String (L Token) (L Token) +lbracket = locSymbol TkLBracket "'['" + +local :: Prod r String (L Token) (L Token) +local = locSymbol TkLocal "'local'" + +lparen :: Prod r String (L Token) (L Token) +lparen = locSymbol TkLParen "'('" + +nil :: Prod r String (L Token) (L Token) +nil = locSymbol TkNil "'nil'" + +rbrace :: Prod r String (L Token) (L Token) +rbrace = locSymbol TkRBrace "'}'" + +rbracket :: Prod r String (L Token) (L Token) +rbracket = locSymbol TkRBracket "']'" + +repeat :: Prod r String (L Token) (L Token) +repeat = locSymbol TkRepeat "'repeat'" + +return' :: Prod r String (L Token) (L Token) +return' = locSymbol TkReturn "'return'" + +rparen :: Prod r String (L Token) (L Token) +rparen = locSymbol TkRParen "')'" + +semi :: Prod r String (L Token) (L Token) +semi = locSymbol TkSemi "';'" + +stringLit :: Prod r String (L Token) (L Token) +stringLit = locSatisfy isStringLit "string" + where + isStringLit :: Token -> Bool + isStringLit (TkStringLit _) = True + isStringLit _ = False + +then' :: Prod r String (L Token) (L Token) +then' = locSymbol TkThen "'then'" + +vararg :: Prod r String (L Token) (L Token) +vararg = locSymbol TkVararg "'...'" + +true :: Prod r String (L Token) (L Token) +true = locSymbol TkTrue "'true'" + +until :: Prod r String (L Token) (L Token) +until = locSymbol TkUntil "'until'" + +while :: Prod r String (L Token) (L Token) +while = locSymbol TkWhile "'while'" + +-------------------------------------------------------------------------------- +-- Earley extras + +locSymbol :: Eq t => t -> Prod r e (L t) (L t) +locSymbol = symbol . L NoLoc + +locSatisfy :: (t -> Bool) -> Prod r e (L t) (L t) +locSatisfy p = satisfy (p . unLoc) diff --git a/src/Language/Lua/Pretty.hs b/src/Language/Lua/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lua/Pretty.hs @@ -0,0 +1,16 @@ +-- | Lua pretty-printing re-exports. All AST nodes are instances of 'Pretty'; +-- this module just re-exports types and top-level rendering functions from +-- . + +module Language.Lua.Pretty + ( -- * re-exports + Doc + , Pretty(..) + , SimpleDoc(..) + , renderPretty + , renderCompact + , displayS + , displayIO + ) where + +import Text.PrettyPrint.Leijen diff --git a/src/Language/Lua/Syntax.hs b/src/Language/Lua/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lua/Syntax.hs @@ -0,0 +1,584 @@ +-- | Abstract syntax of Lua 5.3 source files. See +-- for more information. + +module Language.Lua.Syntax + ( -- * AST nodes + Ident(..) + , IdentList(..) + , IdentList1(..) + , Chunk + , Block(..) + , Statement(..) + , ReturnStatement(..) + , FunctionName(..) + , Variable(..) + , VariableList1(..) + , Expression(..) + , ExpressionList(..) + , ExpressionList1(..) + , PrefixExpression(..) + , FunctionCall(..) + , FunctionArgs(..) + , FunctionBody(..) + , TableConstructor(..) + , Field(..) + , FieldList(..) + , Binop(..) + , Unop(..) + + -- * Annotated typeclass + , Annotated(..) + ) where + +import Data.Data +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.Generics (Generic) +import Lens.Micro +import Prelude hiding ((<$>)) +import Text.PrettyPrint.Leijen + +-- | An identifier, defined as any string of letters, digits, or underscores, +-- not beginning with a digit. +-- +-- +data Ident a + = Ident !a !String + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | Zero or more 'Ident's. +data IdentList a + = IdentList !a ![Ident a] + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | One or more 'Ident's. +data IdentList1 a + = IdentList1 !a !(NonEmpty (Ident a)) + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | A chunk; Lua's compilation unit. +-- +-- +type Chunk = Block + +-- | A block of statements, possibly ending in a return statement. +-- +-- +data Block a + = Block !a ![Statement a] !(Maybe (ReturnStatement a)) + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | A statement. +-- +-- +data Statement a + = EmptyStmt !a -- ^ @;@ + | Assign !a !(VariableList1 a) !(ExpressionList1 a) -- ^ @/var1/, /var2/, /var3/ = /exp1/, /exp2/, /exp3/@ + | FunCall !a !(FunctionCall a) -- ^ @foo.bar(/args/)@ + | Label !a !(Ident a) -- ^ @::label::@ + | Break !a -- ^ @__break__@ + | Goto !a !(Ident a) -- ^ @__goto__ label@ + | Do !a !(Block a) -- ^ @__do__ /block/ __end__@ + | While !a !(Expression a) !(Block a) -- ^ @__while__ /exp/ __do__ /block/ __end__@ + | Repeat !a !(Block a) !(Expression a) -- ^ @__repeat__ /block/ __until__ /exp/@ + | If !a !(NonEmpty (Expression a, Block a)) !(Maybe (Block a)) -- ^ @__if__ /exp/ __then__ /block/ __else__ /block/ __end__@ + | For !a !(Ident a) !(Expression a) !(Expression a) !(Maybe (Expression a)) !(Block a) -- ^ @__for__ x = /exp/ __do__ /block/ __end__@ + | ForIn !a !(IdentList1 a) !(ExpressionList1 a) !(Block a) -- ^ @__for__ a, b, c __in__ /exp1/, /exp2/, /exp3/ __do__ /block/ __end__@ + | FunAssign !a !(FunctionName a) !(FunctionBody a) -- ^ @__function__ name /body/@ + | LocalFunAssign !a !(Ident a) !(FunctionBody a) -- ^ @__local function__ name /body/@ + | LocalAssign !a !(IdentList1 a) !(ExpressionList a) -- ^ @__local__ x, y, z@ + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +data ReturnStatement a + = ReturnStatement !a !(ExpressionList a) -- ^ @__return__ /exp1/, /exp2/@ + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +data FunctionName a + = FunctionName !a !(IdentList1 a) !(Maybe (Ident a)) -- ^ @foo.bar:baz@ + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | A variable. +-- +-- +data Variable a + = VarIdent !a !(Ident a) -- ^ @x@ + | VarField !a !(PrefixExpression a) !(Expression a) -- ^ @/table/[/exp/]@ + | VarFieldName !a !(PrefixExpression a) !(Ident a) -- ^ @/table/.field@ + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | One or more 'Variable's. +data VariableList1 a + = VariableList1 !a !(NonEmpty (Variable a)) + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | An expression. +-- +-- +data Expression a + = Nil !a + | Bool !a !Bool + | Integer !a !String + | Float !a !String + | String !a !String + | Vararg !a + | FunDef !a !(FunctionBody a) + | PrefixExp !a !(PrefixExpression a) + | TableCtor !a !(TableConstructor a) + | Binop !a !(Binop a) !(Expression a) !(Expression a) + | Unop !a !(Unop a) !(Expression a) + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | Zero or more 'Expression's. +data ExpressionList a + = ExpressionList !a ![Expression a] + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | One or more 'Expression's. +data ExpressionList1 a + = ExpressionList1 !a !(NonEmpty (Expression a)) + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +data PrefixExpression a + = PrefixVar !a !(Variable a) + | PrefixFunCall !a !(FunctionCall a) + | Parens !a !(Expression a) + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | A function call. May be a statement or an expression. +-- +-- +-- +-- +data FunctionCall a + = FunctionCall !a !(PrefixExpression a) !(FunctionArgs a) + | MethodCall !a !(PrefixExpression a) !(Ident a) !(FunctionArgs a) + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +data FunctionArgs a + = Args !a !(ExpressionList a) -- ^ @(/exp1/, /exp2/)@ + | ArgsTable !a !(TableConstructor a) -- ^ @{ x = /exp/ }@ + | ArgsString !a !String -- ^ @"str"@ + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +data FunctionBody a + = FunctionBody !a !(IdentList a) !Bool !(Block a) -- ^ @(x, y, ...) /block/ __end__@ + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | A table constructor. +-- +-- +data TableConstructor a + = TableConstructor !a !(FieldList a) -- ^ @{ x = 5, [f(1)] = 6, 7 }@ + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +data Field a + = FieldExp !a !(Expression a) !(Expression a) -- ^ @[/exp1/] = /exp2/@ + | FieldIdent !a !(Ident a) !(Expression a) -- ^ @name = /exp/@ + | Field !a !(Expression a) -- ^ @/exp/@ + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-- | Zero or more 'Field's, separated by @,@ or @;@. +data FieldList a + = FieldList !a ![Field a] + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +data Binop a + = Plus !a -- ^ + + | Minus !a -- ^ \- + | Mult !a -- ^ \* + | FloatDiv !a -- ^ / + | FloorDiv !a -- ^ // + | Exponent !a -- ^ \^ + | Modulo !a -- ^ % + | BitwiseAnd !a -- ^ & + | BitwiseXor !a -- ^ ~ + | BitwiseOr !a -- ^ | + | Rshift !a -- ^ \>\> + | Lshift !a -- ^ << + | Concat !a -- ^ .. + | Lt !a -- ^ < + | Leq !a -- ^ <= + | Gt !a -- ^ \> + | Geq !a -- ^ \>= + | Eq !a -- ^ == + | Neq !a -- ^ ~= + | And !a -- ^ and + | Or !a -- ^ or + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +data Unop a + = Negate !a -- ^ \- + | Not !a -- ^ not + | Length !a -- ^ # + | BitwiseNot !a -- ^ ~ + deriving (Data, Eq, Functor, Generic, Show, Typeable) + +-------------------------------------------------------------------------------- +-- Pretty + +instance Pretty (Ident a) where + pretty (Ident _ s) = text s + +instance Pretty (Block a) where + pretty (Block _ ss mr) = + vsep (map pretty ss) + <$> maybe empty pretty mr + +instance Pretty (Statement a) where + pretty (EmptyStmt _) = char ';' + pretty (Assign _ (VariableList1 _ (v:|vs)) (ExpressionList1 _ (e:|es))) = + sepBy (text ", ") (v:vs) + <+> char '=' + <+> sepBy (text ", ") (e:es) + pretty (FunCall _ f) = pretty f + pretty (Label _ i) = text "::" <> pretty i <> text "::" + pretty (Break _) = text "break" + pretty (Goto _ i) = text "goto" <+> pretty i + pretty (Do _ b) = + text "do" + <$> indent 4 (pretty b) + <$> text "end" + pretty (While _ e b) = + text "while" <+> pretty e <+> text "do" + <$> nest 4 (pretty b) + <$> text "end" + pretty (Repeat _ b e) = + text "repeat" + <$> nest 4 (pretty b) + <$> text "until" <+> pretty e + pretty (If _ ((e,b):|es) mb'') = + text "if" <+> pretty e <+> text "then" + <$> indent 4 (pretty b) + <$> vsep (map (\(e',b') -> text "elseif" <+> pretty e' <+> text "then" + <$> indent 4 (pretty b')) es) + <$> maybe empty (\b'' -> text "else" + <$> indent 4 (pretty b'')) mb'' + <$> text "end" + pretty (For _ i e1 e2 me3 b) = + text "for" <+> pretty i <+> char '=' <+> pretty e1 <> char ',' <+> pretty e2 <> maybe empty ((char ',' <+>) . pretty) me3 <+> text "do" + <$> indent 4 (pretty b) + <$> text "end" + pretty (ForIn _ (IdentList1 _ (i:|is)) (ExpressionList1 _ (e:|es)) b) = + text "for" <+> sepBy (text ", ") (i:is) <+> text "in" <+> sepBy (text ", ") (e:es) <+> text "do" + <$> indent 4 (pretty b) + <$> text "end" + pretty (FunAssign _ n b) = + text "function" <+> pretty n <> pretty b + pretty (LocalFunAssign _ i b) = + text "local" <+> text "function" <+> pretty i <> pretty b + pretty (LocalAssign _ (IdentList1 _ (i:|is)) (ExpressionList _ es)) = + text "local" + <+> sepBy (text ", ") (i:is) + <+> case es of + [] -> empty + _ -> char '=' <+> sepBy (text ", ") es + +instance Pretty (ReturnStatement a) where + pretty (ReturnStatement _ (ExpressionList _ es)) = text "return" <+> sepBy (text ", ") es + +instance Pretty (FunctionName a) where + pretty (FunctionName _ (IdentList1 _ (i:|is)) mi) = sepBy (char '.') (i:is) <> maybe empty ((char ':' <>) . pretty) mi + +instance Pretty (Variable a) where + pretty (VarIdent _ i) = pretty i + pretty (VarField _ e1 e2) = pretty e1 <> brackets (pretty e2) + pretty (VarFieldName _ e i) = pretty e <> char '.' <> pretty i + +instance Pretty (Expression a) where + pretty (Nil _) = text "nil" + pretty (Bool _ True) = text "true" + pretty (Bool _ _) = text "false" + pretty (Integer _ s) = text s + pretty (Float _ s) = text s + pretty (String _ s) = dquotes (string s) + pretty (Vararg _) = text "..." + pretty (FunDef _ b) = text "function" <> pretty b + pretty (PrefixExp _ e) = pretty e + pretty (TableCtor _ t) = pretty t + pretty (Binop _ op e1 e2) = pretty e1 <+> pretty op <+> pretty e2 + pretty (Unop _ op e) = pretty op <> pretty e + +instance Pretty (PrefixExpression a) where + pretty (PrefixVar _ v) = pretty v + pretty (PrefixFunCall _ c) = pretty c + pretty (Parens _ e) = parens (pretty e) + +instance Pretty (FunctionCall a) where + pretty (FunctionCall _ e a) = pretty e <> pretty a + pretty (MethodCall _ e i a) = pretty e <> char ':' <> pretty i <> pretty a + +instance Pretty (FunctionArgs a) where + pretty (Args _ (ExpressionList _ es)) = encloseSep lparen rparen (text ", ") (map pretty es) + pretty (ArgsTable _ t) = pretty t + pretty (ArgsString _ s) = dquotes (string s) + +instance Pretty (FunctionBody a) where + pretty (FunctionBody _ (IdentList _ is) va b) = + encloseSep lparen rhs (text ", ") (map pretty is) + <$> indent 4 (pretty b) + <$> text "end" + where + rhs = if va + then comma <+> text "..." <> rparen + else rparen + +instance Pretty (TableConstructor a) where + pretty (TableConstructor _ (FieldList _ [])) = lbrace <+> rbrace + pretty (TableConstructor _ (FieldList _ [f])) = lbrace <+> pretty f <+> rbrace + pretty (TableConstructor _ (FieldList _ fs)) = + lbrace + <$> indent 4 (vsep (map pretty fs)) + <$> rbrace + +instance Pretty (Field a) where + pretty (FieldExp _ e1 e2) = brackets (pretty e1) <+> char '=' <+> pretty e2 + pretty (FieldIdent _ i e) = pretty i <+> char '=' <+> pretty e + pretty (Field _ e) = pretty e + +instance Pretty (Binop a) where + pretty (Plus _) = char '+' + pretty (Minus _) = char '-' + pretty (Mult _) = char '*' + pretty (FloatDiv _) = char '/' + pretty (FloorDiv _) = text "//" + pretty (Exponent _) = char '^' + pretty (Modulo _) = char '%' + pretty (BitwiseAnd _) = char '&' + pretty (BitwiseXor _) = char '~' + pretty (BitwiseOr _) = char '|' + pretty (Rshift _) = text ">>" + pretty (Lshift _) = text "<<" + pretty (Concat _) = text ".." + pretty (Lt _) = text "<" + pretty (Leq _) = text "<=" + pretty (Gt _) = text ">" + pretty (Geq _) = text ">=" + pretty (Eq _) = text "==" + pretty (Neq _) = text "~=" + pretty (And _) = text "and" + pretty (Or _) = text "or" + +instance Pretty (Unop a) where + pretty (Negate _) = char '-' + pretty (Not _) = text "not" + pretty (Length _) = char '#' + pretty (BitwiseNot _) = char '~' + +sepBy :: Pretty a => Doc -> [a] -> Doc +sepBy d = align . cat . punctuate d . map pretty + +-------------------------------------------------------------------------------- +-- Annotated + +class Functor ast => Annotated ast where + ann :: Lens' (ast a) a + +instance Annotated Ident where + ann = lens (\(Ident a _) -> a) (\(Ident _ b) a -> Ident a b) + +instance Annotated IdentList where + ann = lens (\(IdentList a _) -> a) (\(IdentList _ b) a -> IdentList a b) + +instance Annotated IdentList1 where + ann = lens (\(IdentList1 a _) -> a) (\(IdentList1 _ b) a -> IdentList1 a b) + +instance Annotated Block where + ann = lens (\(Block a _ _) -> a) (\(Block _ b c) a -> Block a b c) + +instance Annotated Statement where + ann = lens f g + where + f (EmptyStmt a) = a + f (Assign a _ _) = a + f (FunCall a _) = a + f (Label a _) = a + f (Break a) = a + f (Goto a _) = a + f (Do a _) = a + f (While a _ _) = a + f (Repeat a _ _) = a + f (If a _ _) = a + f (For a _ _ _ _ _) = a + f (ForIn a _ _ _) = a + f (FunAssign a _ _) = a + f (LocalFunAssign a _ _) = a + f (LocalAssign a _ _) = a + + g (EmptyStmt _) a = EmptyStmt a + g (Assign _ b c) a = Assign a b c + g (FunCall _ b) a = FunCall a b + g (Label _ b) a = Label a b + g (Break _) a = Break a + g (Goto _ b) a = Goto a b + g (Do _ b) a = Do a b + g (While _ b c) a = While a b c + g (Repeat _ b c) a = Repeat a b c + g (If _ b c) a = If a b c + g (For _ b c d e h) a = For a b c d e h + g (ForIn _ b c d) a = ForIn a b c d + g (FunAssign _ b c) a = FunAssign a b c + g (LocalFunAssign _ b c) a = LocalFunAssign a b c + g (LocalAssign _ b c) a = LocalAssign a b c + +instance Annotated ReturnStatement where + ann = lens (\(ReturnStatement a _) -> a) (\(ReturnStatement _ b) a -> ReturnStatement a b) + +instance Annotated FunctionName where + ann = lens (\(FunctionName a _ _) -> a) (\(FunctionName _ b c) a -> FunctionName a b c) + +instance Annotated Variable where + ann = lens f g + where + f (VarIdent a _) = a + f (VarField a _ _) = a + f (VarFieldName a _ _) = a + + g (VarIdent _ b) a = VarIdent a b + g (VarField _ b c) a = VarField a b c + g (VarFieldName _ b c) a = VarFieldName a b c + +instance Annotated VariableList1 where + ann = lens (\(VariableList1 a _) -> a) (\(VariableList1 _ b) a -> VariableList1 a b) + +instance Annotated Expression where + ann = lens f g + where + f (Nil a) = a + f (Bool a _) = a + f (Integer a _) = a + f (Float a _) = a + f (String a _) = a + f (Vararg a) = a + f (FunDef a _) = a + f (PrefixExp a _) = a + f (TableCtor a _) = a + f (Binop a _ _ _) = a + f (Unop a _ _) = a + + g (Nil _) a = Nil a + g (Bool _ b) a = Bool a b + g (Integer _ b) a = Integer a b + g (Float _ b) a = Float a b + g (String _ b) a = String a b + g (Vararg _) a = Vararg a + g (FunDef _ b) a = FunDef a b + g (PrefixExp _ b) a = PrefixExp a b + g (TableCtor _ b) a = TableCtor a b + g (Binop _ b c d) a = Binop a b c d + g (Unop _ b c) a = Unop a b c + +instance Annotated ExpressionList where + ann = lens (\(ExpressionList a _) -> a) (\(ExpressionList _ b) a -> ExpressionList a b) + +instance Annotated ExpressionList1 where + ann = lens (\(ExpressionList1 a _) -> a) (\(ExpressionList1 _ b) a -> ExpressionList1 a b) + +instance Annotated PrefixExpression where + ann = lens f g + where + f (PrefixVar a _) = a + f (PrefixFunCall a _) = a + f (Parens a _) = a + + g (PrefixVar _ b) a = PrefixVar a b + g (PrefixFunCall _ b) a = PrefixFunCall a b + g (Parens _ b) a = Parens a b + +instance Annotated FunctionCall where + ann = lens f g + where + f (FunctionCall a _ _) = a + f (MethodCall a _ _ _) = a + + g (FunctionCall _ b c) a = FunctionCall a b c + g (MethodCall _ b c d) a = MethodCall a b c d + +instance Annotated FunctionArgs where + ann = lens f g + where + f (Args a _) = a + f (ArgsTable a _) = a + f (ArgsString a _) = a + + g (Args _ b) a = Args a b + g (ArgsTable _ b) a = ArgsTable a b + g (ArgsString _ b) a = ArgsString a b + +instance Annotated FunctionBody where + ann = lens (\(FunctionBody a _ _ _) -> a) (\(FunctionBody _ b c d) a -> FunctionBody a b c d) + +instance Annotated TableConstructor where + ann = lens (\(TableConstructor a _) -> a) (\(TableConstructor _ b) a -> TableConstructor a b) + +instance Annotated Field where + ann = lens f g + where + f (FieldExp a _ _) = a + f (FieldIdent a _ _) = a + f (Field a _) = a + + g (FieldExp _ b c) a = FieldExp a b c + g (FieldIdent _ b c) a = FieldIdent a b c + g (Field _ b) a = Field a b + +instance Annotated FieldList where + ann = lens (\(FieldList a _) -> a) (\(FieldList _ b) a -> FieldList a b) + +instance Annotated Binop where + ann = lens f g + where + f (Plus a) = a + f (Minus a) = a + f (Mult a) = a + f (FloatDiv a) = a + f (FloorDiv a) = a + f (Exponent a) = a + f (Modulo a) = a + f (BitwiseAnd a) = a + f (BitwiseXor a) = a + f (BitwiseOr a) = a + f (Rshift a) = a + f (Lshift a) = a + f (Concat a) = a + f (Lt a) = a + f (Leq a) = a + f (Gt a) = a + f (Geq a) = a + f (Eq a) = a + f (Neq a) = a + f (And a) = a + f (Or a) = a + + g (Plus _) a = Plus a + g (Minus _) a = Minus a + g (Mult _) a = Mult a + g (FloatDiv _) a = FloatDiv a + g (FloorDiv _) a = FloorDiv a + g (Exponent _) a = Exponent a + g (Modulo _) a = Modulo a + g (BitwiseAnd _) a = BitwiseAnd a + g (BitwiseXor _) a = BitwiseXor a + g (BitwiseOr _) a = BitwiseOr a + g (Rshift _) a = Rshift a + g (Lshift _) a = Lshift a + g (Concat _) a = Concat a + g (Lt _) a = Lt a + g (Leq _) a = Leq a + g (Gt _) a = Gt a + g (Geq _) a = Geq a + g (Eq _) a = Eq a + g (Neq _) a = Neq a + g (And _) a = And a + g (Or _) a = Or a + +instance Annotated Unop where + ann = lens f g + where + f (Negate a) = a + f (Not a) = a + f (Length a) = a + f (BitwiseNot a) = a + + g (Negate _) a = Negate a + g (Not _) a = Not a + g (Length _) a = Length a + g (BitwiseNot _) a = BitwiseNot a diff --git a/src/Language/Lua/Token.hs b/src/Language/Lua/Token.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lua/Token.hs @@ -0,0 +1,131 @@ +module Language.Lua.Token where + +import Data.Data +import GHC.Generics (Generic) + +data Token + = TkAnd -- ^ and + | TkBreak -- ^ break + | TkDo -- ^ do + | TkElse -- ^ else + | TkElseif -- ^ elseif + | TkEnd -- ^ end + | TkFalse -- ^ false + | TkFor -- ^ for + | TkFunction -- ^ function + | TkGoto -- ^ goto + | TkIf -- ^ if + | TkIn -- ^ in + | TkLocal -- ^ local + | TkNil -- ^ nil + | TkNot -- ^ not + | TkOr -- ^ or + | TkRepeat -- ^ repeat + | TkReturn -- ^ return + | TkThen -- ^ then + | TkTrue -- ^ true + | TkUntil -- ^ until + | TkWhile -- ^ while + | TkPlus -- ^ + + | TkDash -- ^ \- + | TkMult -- ^ \* + | TkFloatDiv -- ^ / + | TkModulo -- ^ % + | TkExponent -- ^ ^ + | TkLength -- ^ # + | TkBitwiseAnd -- ^ & + | TkTilde -- ^ ~ + | TkBitwiseOr -- ^ | + | TkLShift -- ^ << + | TkRShift -- ^ \>\> + | TkFloorDiv -- ^ // + | TkEq -- ^ == + | TkNeq -- ^ ~= + | TkLeq -- ^ <= + | TkGeq -- ^ \>= + | TkLt -- ^ < + | TkGt -- ^ > + | TkAssign -- ^ = + | TkLParen -- ^ ( + | TkRParen -- ^ ) + | TkLBrace -- ^ { + | TkRBrace -- ^ } + | TkLBracket -- ^ [ + | TkRBracket -- ^ ] + | TkLabel -- ^ :: + | TkSemi -- ^ ; + | TkColon -- ^ : + | TkComma -- ^ , + | TkDot -- ^ . + | TkConcat -- ^ .. + | TkVararg -- ^ ... + | TkQuote -- ^ ' + | TkDoubleQuote -- ^ " + | TkIdent String + | TkStringLit String + | TkIntLit String + | TkFloatLit String + deriving (Data, Eq, Generic, Show, Typeable) + +showToken :: Token -> String +showToken TkAnd = "and" +showToken TkBreak = "break" +showToken TkDo = "do" +showToken TkElse = "else" +showToken TkElseif = "elseif" +showToken TkEnd = "end" +showToken TkFalse = "false" +showToken TkFor = "for" +showToken TkFunction = "function" +showToken TkGoto = "goto" +showToken TkIf = "if" +showToken TkIn = "in" +showToken TkLocal = "local" +showToken TkNil = "nil" +showToken TkNot = "not" +showToken TkOr = "or" +showToken TkRepeat = "repeat" +showToken TkReturn = "return" +showToken TkThen = "then" +showToken TkTrue = "true" +showToken TkUntil = "until" +showToken TkWhile = "while" +showToken TkPlus = "+" +showToken TkDash = "-" +showToken TkMult = "*" +showToken TkFloatDiv = "/" +showToken TkModulo = "%" +showToken TkExponent = "^" +showToken TkLength = "#" +showToken TkBitwiseAnd = "&" +showToken TkTilde = "~" +showToken TkBitwiseOr = "|" +showToken TkLShift = "<<" +showToken TkRShift = ">>" +showToken TkFloorDiv = "//" +showToken TkEq = "==" +showToken TkNeq = "~=" +showToken TkLeq = "<=" +showToken TkGeq = ">=" +showToken TkLt = "<" +showToken TkGt = ">" +showToken TkAssign = "=" +showToken TkLParen = "(" +showToken TkRParen = ")" +showToken TkLBrace = "{" +showToken TkRBrace = "}" +showToken TkLBracket = "[" +showToken TkRBracket = "]" +showToken TkLabel = "::" +showToken TkSemi = ";" +showToken TkColon = ":" +showToken TkComma = "," +showToken TkDot = "." +showToken TkConcat = ".." +showToken TkVararg = "..." +showToken TkQuote = "'" +showToken TkDoubleQuote = "\"" +showToken (TkIdent s) = s +showToken (TkStringLit s) = s +showToken (TkIntLit s) = s +showToken (TkFloatLit s) = s diff --git a/test/Instances.hs b/test/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Instances.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Instances where + +import Language.Lua.Syntax + +import Control.Applicative +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen + +instance Arbitrary a => Arbitrary (Ident a) where + arbitrary = Ident <$> arbitrary <*> genIdent + where + genIdent :: Gen String + genIdent = liftA2 (:) first rest `suchThat` \s -> not (HS.member s keywords) + where + first :: Gen Char + first = frequency [(5, pure '_'), (95, arbitrary `suchThat` isAsciiLetter)] + + rest :: Gen String + rest = listOf $ + frequency [ (10, pure '_') + , (45, arbitrary `suchThat` isAsciiLetter) + , (45, arbitrary `suchThat` isDigit) + ] + + -- Meh, forget unicode for now. + isAsciiLetter :: Char -> Bool + isAsciiLetter c = isAsciiLower c || isAsciiUpper c + + keywords :: HashSet String + keywords = [ "and", "break", "do", "else", "elseif", "end", "false" + , "for", "function", "goto", "if", "in", "local", "nil" + , "not", "or", "repeat", "return", "then", "true", "until", "while" + ] + +instance Arbitrary a => Arbitrary (IdentList a) where + arbitrary = IdentList <$> arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary a => Arbitrary (IdentList1 a) where + arbitrary = IdentList1 <$> arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary a => Arbitrary (Block a) where + arbitrary = Block <$> arbitrary <*> listOf1 arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary a => Arbitrary (Statement a) where + arbitrary = oneof + [ EmptyStmt <$> arbitrary + , Assign <$> arbitrary <*> arbitrary <*> arbitrary + , FunCall <$> arbitrary <*> arbitrary + , Label <$> arbitrary <*> arbitrary + , Break <$> arbitrary + , Goto <$> arbitrary <*> arbitrary + , Do <$> arbitrary <*> arbitrary + , While <$> arbitrary <*> arbitrary <*> arbitrary + , Repeat <$> arbitrary <*> arbitrary <*> arbitrary + , If <$> arbitrary <*> arbitrary <*> arbitrary + , For <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , ForIn <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , FunAssign <$> arbitrary <*> arbitrary <*> arbitrary + , LocalFunAssign <$> arbitrary <*> arbitrary <*> arbitrary + , LocalAssign <$> arbitrary <*> arbitrary <*> arbitrary + ] + + shrink = genericShrink + +instance Arbitrary a => Arbitrary (ReturnStatement a) where + arbitrary = ReturnStatement <$> arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary a => Arbitrary (FunctionName a) where + arbitrary = FunctionName <$> arbitrary <*> arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary a => Arbitrary (Variable a) where + arbitrary = oneof + [ VarIdent <$> arbitrary <*> arbitrary + , VarField <$> arbitrary <*> arbitrary <*> arbitrary + , VarFieldName <$> arbitrary <*> arbitrary <*> arbitrary + ] + + shrink = genericShrink + +instance Arbitrary a => Arbitrary (VariableList1 a) where + arbitrary = VariableList1 <$> arbitrary <*> arbitrary + +instance Arbitrary a => Arbitrary (Expression a) where + arbitrary = oneof + [ Nil <$> arbitrary + , Bool <$> arbitrary <*> arbitrary + , Integer <$> arbitrary <*> (show <$> (arbitrary :: Gen Int)) -- TODO: Make these better + , Float <$> arbitrary <*> (show <$> (arbitrary :: Gen Float)) + , String <$> arbitrary <*> arbitrary + , Vararg <$> arbitrary + , FunDef <$> arbitrary <*> arbitrary + , PrefixExp <$> arbitrary <*> arbitrary + , TableCtor <$> arbitrary <*> arbitrary + , Binop <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , Unop <$> arbitrary <*> arbitrary <*> arbitrary + ] + + shrink = genericShrink + +instance Arbitrary a => Arbitrary (ExpressionList a) where + arbitrary = ExpressionList <$> arbitrary <*> arbitrary + +instance Arbitrary a => Arbitrary (ExpressionList1 a) where + arbitrary = ExpressionList1 <$> arbitrary <*> arbitrary + +instance Arbitrary a => Arbitrary (PrefixExpression a) where + arbitrary = oneof + [ PrefixVar <$> arbitrary <*> arbitrary + , PrefixFunCall <$> arbitrary <*> arbitrary + , Parens <$> arbitrary <*> arbitrary + ] + + shrink = genericShrink + +instance Arbitrary a => Arbitrary (FunctionCall a) where + arbitrary = oneof + [ FunctionCall <$> arbitrary <*> arbitrary <*> arbitrary + , MethodCall <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + ] + + shrink = genericShrink + +instance Arbitrary a => Arbitrary (FunctionArgs a) where + arbitrary = oneof + [ Args <$> arbitrary <*> arbitrary + , ArgsTable <$> arbitrary <*> arbitrary + , ArgsString <$> arbitrary <*> arbitrary + ] + + shrink = genericShrink + +instance Arbitrary a => Arbitrary (FunctionBody a) where + arbitrary = FunctionBody <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary a => Arbitrary (TableConstructor a) where + arbitrary = TableConstructor <$> arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary a => Arbitrary (Field a) where + arbitrary = oneof + [ FieldExp <$> arbitrary <*> arbitrary <*> arbitrary + , FieldIdent <$> arbitrary <*> arbitrary <*> arbitrary + , Field <$> arbitrary <*> arbitrary + ] + + shrink = genericShrink + +instance Arbitrary a => Arbitrary (FieldList a) where + arbitrary = FieldList <$> arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary a => Arbitrary (Binop a) where + arbitrary = oneof + [ Plus <$> arbitrary + , Minus <$> arbitrary + , Mult <$> arbitrary + , FloatDiv <$> arbitrary + , FloorDiv <$> arbitrary + , Exponent <$> arbitrary + , Modulo <$> arbitrary + , BitwiseAnd <$> arbitrary + , BitwiseXor <$> arbitrary + , BitwiseOr <$> arbitrary + , Rshift <$> arbitrary + , Lshift <$> arbitrary + , Concat <$> arbitrary + , Lt <$> arbitrary + , Leq <$> arbitrary + , Gt <$> arbitrary + , Geq <$> arbitrary + , Eq <$> arbitrary + , Neq <$> arbitrary + , And <$> arbitrary + , Or <$> arbitrary + ] + + shrink = genericShrink + +instance Arbitrary a => Arbitrary (Unop a) where + arbitrary = oneof + [ Negate <$> arbitrary + , Not <$> arbitrary + , Length <$> arbitrary + , BitwiseNot <$> arbitrary + ] + + shrink = genericShrink + +-- Orphans + +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = NE.fromList <$> listOf1 arbitrary diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,71 @@ +module Main where + +import Instances () +import Language.Lua.Lexer +import Language.Lua.Parser +import Language.Lua.Pretty +import Language.Lua.Syntax +import Language.Lua.Token + +import Data.Loc +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import qualified Test.Tasty.QuickCheck as QC + +main :: IO () +main = defaultMain $ testGroup "tests" + [ lexerTests + -- TODO: Make smarter shrinks and re-enable + -- , parserTests + ] + +lexerTests :: TestTree +lexerTests = testGroup "lexer tests" + [ stringLiteralTests + , intLiteralTests + , floatLiteralTests + ] + where + stringLiteralTests :: TestTree + stringLiteralTests = testCase "string literals" $ do + let tk = [TkStringLit "alo\n123\""] + l "\'alo\\\n123\"\'" @?= tk + l "\"alo\\\n123\\\"\"" @?= tk + l "\'\\97lo\\10\\04923\"\'" @?= tk + l "[[alo\n123\"]]" @?= tk + l "[==[\nalo\n123\"]==]" @?= tk + + intLiteralTests :: TestTree + intLiteralTests = testCase "int literals" $ do + l "3" @?= [TkIntLit "3"] + l "345" @?= [TkIntLit "345"] + l "0xff" @?= [TkIntLit "0xff"] + l "0XBEBada" @?= [TkIntLit "0XBEBada"] + + floatLiteralTests :: TestTree + floatLiteralTests = testCase "float literals" $ do + l "3." @?= [TkFloatLit "3."] + l "3.1416" @?= [TkFloatLit "3.1416"] + l "3.14e-2" @?= [TkFloatLit "3.14e-2"] + l "3.14E+2" @?= [TkFloatLit "3.14E+2"] + l "3.14E2" @?= [TkFloatLit "3.14E2"] + l "0x0.1E" @?= [TkFloatLit "0x0.1E"] + l "0xA23p-4" @?= [TkFloatLit "0xA23p-4"] + l "0X1.92P+1" @?= [TkFloatLit "0X1.92P+1"] + l "0X1.92p1" @?= [TkFloatLit "0X1.92p1"] + + l :: String -> [Token] + l = map unLoc . streamToList . runLexer luaLexer "" + +parserTests :: TestTree +parserTests = QC.testProperty "Pretty-printer round-trip" (\luaAst -> luaFromString (luaToString luaAst) == Just luaAst) + +luaToString :: Chunk () -> String +luaToString c = displayS (renderPretty 1.0 80 (pretty c)) "" + +luaFromString :: String -> Maybe (Chunk ()) +luaFromString s = either (const Nothing) Just (streamToEitherList (runLexer luaLexer "" s)) >>= \tks -> + case fullParses (parser luaChunk tks) of + ([c], _) -> Just (() <$ c) + _ -> Nothing