language-lua2 (empty) → 0.1.0.0
raw patch · 13 files changed
+2406/−0 lines, 13 filesdep +Earleydep +QuickCheckdep +basesetup-changed
Dependencies added: Earley, QuickCheck, base, containers, language-lua2, lexer-applicative, microlens, optparse-applicative, regex-applicative, semigroups, srcloc, tasty, tasty-hunit, tasty-quickcheck, transformers, unordered-containers, wl-pprint
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/Lex.hs +14/−0
- app/Parse.hs +60/−0
- language-lua2.cabal +104/−0
- src/Language/Lua/Internal.hs +5/−0
- src/Language/Lua/Lexer.hs +278/−0
- src/Language/Lua/Parser.hs +905/−0
- src/Language/Lua/Pretty.hs +16/−0
- src/Language/Lua/Syntax.hs +584/−0
- src/Language/Lua/Token.hs +131/−0
- test/Instances.hs +206/−0
- test/Spec.hs +71/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Lex.hs view
@@ -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 "]"
+ app/Parse.hs view
@@ -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 "<stdin>"+ StatementMode -> forever $ getLine >>= go luaStatement "<stdin>"+ ExpressionMode -> forever $ getLine >>= go luaExpression "<stdin>"+ 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
+ language-lua2.cabal view
@@ -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
+ src/Language/Lua/Internal.hs view
@@ -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
+ src/Language/Lua/Lexer.hs view
@@ -0,0 +1,278 @@+module Language.Lua.Lexer+ ( luaLexer++ -- * <https://hackage.haskell.org/package/lexer-applicative lexer-applicative> 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
+ src/Language/Lua/Parser.hs view
@@ -0,0 +1,905 @@+module Language.Lua.Parser+ ( -- * Lua parsers+ parseLua+ , parseLuaWith+ , LuaParseException(..)++ -- * Lua grammars+ , LuaGrammar+ , luaChunk+ , luaStatement+ , luaExpression+ , NodeInfo(..)+ , nodeLoc+ , nodeTokens++ -- * <https://hackage.haskell.org/package/Earley Earley> 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: <EOF>"+ ]+ 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 <http://www.lua.org/manual/5.3/manual.html#3.3.1> for a likely explanation.\n"+ in case r of+ Report _ xs [] -> unlines+ [ filename ++ ":"+ , " " ++ s+ , " Expected one of: " ++ intercalate ", " xs+ , " But found: <EOF>"+ ]+ 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)
+ src/Language/Lua/Pretty.hs view
@@ -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+-- <https://hackage.haskell.org/package/wl-pprint wl-pprint>.++module Language.Lua.Pretty+ ( -- * <https://hackage.haskell.org/package/wl-pprint wl-pprint> re-exports+ Doc+ , Pretty(..)+ , SimpleDoc(..)+ , renderPretty+ , renderCompact+ , displayS+ , displayIO+ ) where++import Text.PrettyPrint.Leijen
+ src/Language/Lua/Syntax.hs view
@@ -0,0 +1,584 @@+-- | Abstract syntax of Lua 5.3 source files. See+-- <http://www.lua.org/manual/5.3/> 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.+--+-- <http://www.lua.org/manual/5.3/manual.html#3.1>+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.+--+-- <http://www.lua.org/manual/5.3/manual.html#3.3.2>+type Chunk = Block++-- | A block of statements, possibly ending in a return statement.+--+-- <http://www.lua.org/manual/5.3/manual.html#3.3.1>+data Block a+ = Block !a ![Statement a] !(Maybe (ReturnStatement a))+ deriving (Data, Eq, Functor, Generic, Show, Typeable)++-- | A statement.+--+-- <http://www.lua.org/manual/5.3/manual.html#3.3>+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.+--+-- <http://www.lua.org/manual/5.3/manual.html#3.2>+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.+--+-- <http://www.lua.org/manual/5.3/manual.html#3.4>+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.+--+-- <http://www.lua.org/manual/5.3/manual.html#3.3.6>+--+-- <http://www.lua.org/manual/5.3/manual.html#3.4.10>+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.+--+-- <http://www.lua.org/manual/5.3/manual.html#3.4.9>+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
+ src/Language/Lua/Token.hs view
@@ -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
+ test/Instances.hs view
@@ -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
+ test/Spec.hs view
@@ -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