diff --git a/language-lua2.cabal b/language-lua2.cabal --- a/language-lua2.cabal +++ b/language-lua2.cabal @@ -1,5 +1,5 @@ name: language-lua2 -version: 0.1.0.3 +version: 0.1.0.4 synopsis: Lua parser and pretty printer description: Lua parser and pretty printer homepage: http://github.com/mitchellwrosen/language-lua2 @@ -86,6 +86,7 @@ main-is: Spec.hs other-modules: Instances build-depends: base + , deepseq , lexer-applicative , language-lua2 , QuickCheck @@ -95,7 +96,7 @@ , tasty-hunit , tasty-quickcheck , unordered-containers - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -K1K" default-extensions: FlexibleInstances default-language: Haskell2010 diff --git a/src/Language/Lua/Lexer.hs b/src/Language/Lua/Lexer.hs --- a/src/Language/Lua/Lexer.hs +++ b/src/Language/Lua/Lexer.hs @@ -213,14 +213,28 @@ , whitespace $ longest luaLineComment ] +-- A comment starts with a double hyphen (--) anywhere outside a string. If the +-- text immediately after -- is not an opening long bracket, the comment is a +-- short comment, which runs until the end of the line. Otherwise, it is a long +-- comment, which runs until the corresponding closing long bracket. Long +-- comments are frequently used to disable code temporarily. + luaBlockCommentPrefix :: RE Char String -luaBlockCommentPrefix = "--[" *> many (sym '=') <* sym '[' +luaBlockCommentPrefix = "--[[" -luaBlockCommentSuffix :: String -> RE Char Char -luaBlockCommentSuffix xs = many anySym *> "--]" *> exactlyN (length xs) (sym '=') *> sym ']' +luaBlockCommentSuffix :: String -> RE Char String +luaBlockCommentSuffix _ = many anySym *> "]]" luaLineComment :: RE Char String -luaLineComment = "--" *> many (psym (/= '\n')) +luaLineComment = + "--" + <|> "--\n" + <|> "--" *> psym p *> many (psym (/= '\n')) + <|> "--[\n" + <|> "--[" *> psym p *> many (psym (/= '\n')) + where + p :: Char -> Bool + p c = c /= '[' && c /= '\n' -------------------------------------------------------------------------------- -- Regex extras diff --git a/src/Language/Lua/Parser.hs b/src/Language/Lua/Parser.hs --- a/src/Language/Lua/Parser.hs +++ b/src/Language/Lua/Parser.hs @@ -376,6 +376,7 @@ <|> mkFloat <$> floatLit <|> mkString <$> stringLit <|> mkVararg <$> vararg + <|> mkFunDef <$> function <*> functionBody <|> mkPrefixExp <$> prefixExpression <|> mkTableCtor <$> tableConstructor @@ -676,6 +677,9 @@ mkVararg :: L Token -> Expression NodeInfo mkVararg = Vararg . nodeInfo + +mkFunDef :: L Token -> FunctionBody NodeInfo -> Expression NodeInfo +mkFunDef a b = FunDef (nodeInfo a <> nodeInfo b) b mkPrefixExp :: PrefixExpression NodeInfo -> Expression NodeInfo mkPrefixExp a = PrefixExp (nodeInfo a) a diff --git a/src/Language/Lua/Token.hs b/src/Language/Lua/Token.hs --- a/src/Language/Lua/Token.hs +++ b/src/Language/Lua/Token.hs @@ -4,63 +4,63 @@ 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 -- ^ " + = 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 diff --git a/test/Instances.hs b/test/Instances.hs --- a/test/Instances.hs +++ b/test/Instances.hs @@ -1,21 +1,31 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Instances where +import Language.Lua.Token import Language.Lua.Syntax +import Language.Lua.Parser (NodeInfo) import Control.Applicative +import Control.DeepSeq 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 Data.Loc (L(..), Loc(..), Pos(..)) +import GHC.Generics (Generic) import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen +-------------------------------------------------------------------------------- +-- Arbitrary + #if !MIN_VERSION_base(4,8,0) import Data.Typeable (Typeable) type C a = (Arbitrary a, Typeable a) @@ -210,7 +220,44 @@ shrink = genericShrink +-------------------------------------------------------------------------------- +-- NFData + +instance NFData NodeInfo +instance NFData Token + +instance NFData a => NFData (Ident a) +instance NFData a => NFData (IdentList a) +instance NFData a => NFData (IdentList1 a) +instance NFData a => NFData (Block a) +instance NFData a => NFData (Statement a) +instance NFData a => NFData (ReturnStatement a) +instance NFData a => NFData (FunctionName a) +instance NFData a => NFData (Variable a) +instance NFData a => NFData (VariableList1 a) +instance NFData a => NFData (Expression a) +instance NFData a => NFData (ExpressionList a) +instance NFData a => NFData (ExpressionList1 a) +instance NFData a => NFData (PrefixExpression a) +instance NFData a => NFData (FunctionCall a) +instance NFData a => NFData (FunctionArgs a) +instance NFData a => NFData (FunctionBody a) +instance NFData a => NFData (TableConstructor a) +instance NFData a => NFData (Field a) +instance NFData a => NFData (FieldList a) +instance NFData a => NFData (Binop a) +instance NFData a => NFData (Unop a) + -- Orphans instance Arbitrary a => Arbitrary (NonEmpty a) where arbitrary = NE.fromList <$> listOf1 arbitrary + +deriving instance Generic a => Generic (L a) +instance (Generic a, NFData a) => NFData (L a) + +deriving instance Generic Loc +instance NFData Loc + +deriving instance Generic Pos +instance NFData Pos diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,6 +12,8 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$)) #endif +import Control.DeepSeq (rnf) +import Control.Exception (evaluate) import Data.Loc import Test.QuickCheck import Test.Tasty @@ -21,8 +23,7 @@ main :: IO () main = defaultMain $ testGroup "tests" [ lexerTests - -- TODO: Make smarter shrinks and re-enable - -- , parserTests + , parserTests ] lexerTests :: TestTree @@ -30,6 +31,7 @@ [ stringLiteralTests , intLiteralTests , floatLiteralTests + , commentTests ] where stringLiteralTests :: TestTree @@ -60,11 +62,30 @@ l "0X1.92P+1" @?= [TkFloatLit "0X1.92P+1"] l "0X1.92p1" @?= [TkFloatLit "0X1.92p1"] + commentTests :: TestTree + commentTests = testCase "comments" $ do + l "--" @?= [] + l "--just a comment" @?= [] + l "-- just a comment" @?= [] + l "3 -- hi" @?= [TkIntLit "3"] + l "3 --[ hi" @?= [TkIntLit "3"] + l "3 --[\nhi" @?= [TkIntLit "3", TkIdent "hi"] + l "3 --[[hello\nworld]] 4" @?= [TkIntLit "3", TkIntLit "4"] + l :: String -> [Token] l = map unLoc . streamToList . runLexer luaLexer "" parserTests :: TestTree -parserTests = QC.testProperty "Pretty-printer round-trip" (\luaAst -> luaFromString (luaToString luaAst) == Just luaAst) +parserTests = testGroup "parser tests" + [ testCase "parse 1.lua" (parseFile "test/samples/1.lua") + , testCase "parse 2.lua" (parseFile "test/samples/2.lua") + + -- TODO: Make smarter shrinks and re-enable + -- , QC.testProperty "Pretty-printer round-trip" (\luaAst -> luaFromString (luaToString luaAst) == Just luaAst) + ] + +parseFile :: String -> IO () +parseFile file = readFile file >>= evaluate . rnf . parseLua file luaToString :: Chunk () -> String luaToString c = displayS (renderPretty 1.0 80 (pretty c)) ""