Fix a whole bunch of Lua parser/printing issues

 - Correctly emit semicolons when needed. We're a little overeager in
   emitting them in some cases, but this is sufficiently good heuristic
   right now.
 - Correct binary operator's precedence within the Lua parser. (Closes
   #194)

Author: SquidDev

.travis.yml

@@ -21,5 +21,5 @@ install:
 
 script:
 - stack --no-terminal build --fast --ghc-options "-Werror -fmax-pmcheck-iterations=5000000"
-- env AMC_LIBRARY_PATH=$PWD/lib/ stack --no-terminal test --fast --ghc-options "-Werror -fmax-pmcheck-iterations=5000000" --test-arguments "--xml junit.xml --display t"
+- env AMC_LIBRARY_PATH=$PWD/lib/ stack --no-terminal test --fast --ghc-options "-Werror -fmax-pmcheck-iterations=5000000" --test-arguments "--xml junit.xml --display t --hedgehog-tests 10000"
 - stack --no-terminal exec --package=hlint -- hlint --git

amuletml.cabal

@@ -145,6 +145,8 @@ test-suite tests
 
                      , Test.Parser.Lexer
                      , Test.Parser.Parser
+
+                     , Test.Lua.Gen
                      , Test.Lua.Parser
   default-language:    Haskell2010
 

compiler/Test/Lua/Gen.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE GADTs, OverloadedStrings #-}
+module Test.Lua.Gen
+  ( genExpr
+  , genStmt
+  , genStmts
+  ) where
+
+import Control.Monad.Identity
+
+import qualified Data.Set as Set
+import qualified Data.Text as T
+
+import Language.Lua.Syntax
+
+import qualified Hedgehog.Range as Range
+import qualified Hedgehog.Gen as Gen
+import Hedgehog
+
+genIdent :: (MonadGen m, GenBase m ~ Identity) => m T.Text
+genIdent = Gen.filter (`Set.notMember` keywords) $ do
+  first <- Gen.element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_"
+  rest <- Gen.text (Range.linear 0 25) (Gen.element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_")
+  pure (T.cons first rest)
+
+genVar :: (MonadGen m, GenBase m ~ Identity) => m LuaVar
+genVar =
+  Gen.recursive Gen.choice
+    [ genName ]
+    [ LuaIndex <$> genExpr <*> genKey ]
+
+genName :: (MonadGen m, GenBase m ~ Identity) => m LuaVar
+genName = LuaName <$> genIdent
+
+genKey :: (MonadGen m, GenBase m ~ Identity) => m LuaExpr
+genKey = Gen.frequency [(3, LuaString <$> genIdent), (1, genExpr)]
+
+genExpr :: (MonadGen m, GenBase m ~ Identity) => m LuaExpr
+genExpr =
+  Gen.recursive Gen.choice
+  [ pure LuaNil, pure LuaTrue, pure LuaFalse, pure LuaDots
+  , LuaNumber . (/2^(3::Int)) . fromInteger <$> Gen.integral (Range.exponential 0 (2^dR))
+  , LuaInteger <$> Gen.int (Range.exponential 0 (2^iR))
+  , LuaString <$> Gen.text (Range.linear 0 200) Gen.lower -- TODO Gen.ascii
+  , LuaRef <$> genName
+  ]
+  [ LuaCallE <$> genCall
+  , LuaRef <$> genVar
+  , LuaFunction <$> Gen.list (Range.linear 0 5) genName <*>  genStmts
+  , LuaTable <$> Gen.list (Range.linear 0 15) ((,) <$> genKey <*> genExpr)
+  , LuaBinOp <$> genExpr <*> genBin <*> genExpr
+  , LuaUnOp <$> genUn <*> genExpr
+  ]
+
+  where
+    dR , iR :: Int
+    dR = 10
+    iR = 24
+
+    genBin = Gen.element
+      [ "+", "-", "*", "/", "%", "^", "..", "==", "~=", ">", "<", ">=", "<="
+      , "and", "or" ]
+    genUn = Gen.element ["-", "not"]
+
+genCall :: (MonadGen m, GenBase m ~ Identity) => m LuaCall
+genCall = Gen.frequency
+  [(5, LuaCall <$> genExpr <*> Gen.list (Range.linear 0 5) genExpr)
+  ,(1, LuaInvoke <$> genExpr <*> genIdent <*> Gen.list (Range.linear 0 5) genExpr)
+  ]
+
+genStmts :: (MonadGen m, GenBase m ~ Identity) => m [LuaStmt]
+genStmts =
+  (++) <$> Gen.list (Range.linear 0 10) genStmt
+       <*> Gen.frequency
+           [ (5, pure [])
+           , (1, pure . LuaReturn <$> Gen.list (Range.linear 0 5) genExpr)
+           , (1, pure [LuaBreak])
+           ]
+
+genStmt :: (MonadGen m, GenBase m ~ Identity) => m LuaStmt
+genStmt =
+  Gen.recursive Gen.choice
+  [  ]
+  [ LuaDo <$> genStmts
+  , LuaAssign <$> Gen.list (Range.linear 1 5) genVar <*> Gen.list (Range.linear 1 5) genExpr
+  , LuaWhile <$> genExpr <*> genStmts
+  , LuaRepeat <$> genStmts <*> genExpr
+  , LuaFornum <$> genName <*> genExpr <*> genExpr <*> genCounter <*> genStmts
+  , LuaFor <$> Gen.list (Range.linear 1 5) genName <*> Gen.list (Range.linear 1 5) genExpr <*> genStmts
+  , LuaLocal <$> Gen.list (Range.linear 1 5) genName <*> Gen.list (Range.linear 0 5) genExpr
+  , LuaLocalFun <$> genName <*> Gen.list (Range.linear 0 5) genName <*> genStmts
+  , LuaIfElse <$> Gen.list (Range.linear 1 5) ((,) <$> genElseExpr <*> genStmts)
+  ]
+
+  where
+    genElseExpr = Gen.frequency [(3, genExpr), (1, pure LuaTrue)]
+    genCounter = Gen.frequency [(3, pure (LuaInteger 1)), (1, genExpr)]

compiler/Test/Lua/Parser.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Test.Lua.Parser (tests) where
 
+import Test.Lua.Gen
 import Test.Tasty
 import Test.Util
 
@@ -11,6 +13,8 @@ import Language.Lua.Parser
 import qualified Text.Pretty.Note as N
 import Text.Pretty.Semantic
 
+import Hedgehog
+
 result :: String -> T.Text -> T.Text
 result file contents =
   case parseStmts (SourcePos file 1 1) (L.fromStrict contents) of
@@ -19,5 +23,21 @@ result file contents =
 
   where prettyErr = N.format (N.fileSpans [(file, contents)] N.defaultHighlight)
 
+prop_roundtripStmts :: Property
+prop_roundtripStmts = withTests 1000 . property $ do
+  stmts <- forAllWith (show . pretty) genStmts
+  tripping stmts (display . renderPretty 0.4 100 . pretty) (parseStmts (SourcePos "in" 1 1) . L.fromStrict)
+
+prop_roundtripExpr :: Property
+prop_roundtripExpr = withTests 1000 . property $ do
+  stmts <- forAllWith (show . pretty) genExpr
+  tripping stmts (display . renderPretty 0.4 100 . pretty) (parseExpr (SourcePos "in" 1 1) . L.fromStrict)
+
+
 tests :: IO TestTree
-tests = testGroup "Test.Lua.Parser" <$> goldenDir result "tests/lua_parse/" ".lua"
+tests = do
+  golden <- goldenDir result "tests/lua_parse/" ".lua"
+  pure $ testGroup "Test.Lua.Parser"
+    [ testGroup "Golden" golden
+    , hedgehog $ $$(discover)
+    ]

compiler/Test/Types/Unify.hs

@@ -16,9 +16,9 @@ import Syntax
 
 prop_unifyMakesGoodCoercion :: Property
 prop_unifyMakesGoodCoercion = property $ do
-  aty <- forAllWith (displayS . displayType) genType
+  aty <- forAllWith (show . displayType) genType
   case unify aty aty of
-    Left e -> (footnote . displayS . pretty . toList $ e) *> failure
+    Left e -> (footnote . show . pretty . toList $ e) *> failure
     Right x | (ca, cb) <- provenCoercion x -> do
       footnote . displayS $
           keyword "Given type:" <+> displayType aty

src/Language/Lua/Parser/Error.hs

@@ -41,7 +41,7 @@ data ParseError
   | UnexpectedToken Token [String]
   -- | An expression, where a statement was expected
   | MalformedStatement
-  deriving (Show)
+  deriving (Eq, Show)
 
 instance Pretty ParseError where
   pretty (Failure _ s) = string s

src/Language/Lua/Parser/Parser.y

@@ -99,13 +99,13 @@ import Language.Lua.Syntax
   float    { Token (TcFloat _) _ _ }
   string   { Token (TcString  _) _ _ }
 
-%right '^'
-%left '*' '/' '%'
-%left '+' '-'
-%right '..'
-%left '<' '>' '<=' '>=' '~=' '=='
-%left and
 %left or
+%left and
+%left '<' '>' '<=' '>=' '~=' '=='
+%right '..'
+%left '+' '-'
+%left '*' '/' '%'
+%right '^'
 %%
 
 Ident :: { LuaVar }
@@ -203,10 +203,11 @@ Stmt :: { LuaStmt }
   | for Ident '=' Expr ',' Expr do Stmts end          { LuaFornum $2 $4 $6 (LuaInteger 1) $8 }
   | for Ident '=' Expr ',' Expr ',' Expr do Stmts end { LuaFornum $2 $4 $6 $8 $10 }
   | for List1(Ident, ',') in List1(Expr, ',') do Stmts end { LuaFor $2 $4 $6 }
+  | local List1(Ident, ',')             { LuaLocal $2 [] }
   | local List1(Ident, ',') '=' List1(Expr, ',') { LuaLocal $2 $4 }
   | local function Ident '(' List(Ident, ',') ')' Stmts end { LuaLocalFun $3 $5 $7 }
   | function Ident '(' List(Ident, ',') ')' Stmts end { LuaAssign [$2] [LuaFunction $4 $6] }
-  | return List1(Expr, ',')             { LuaReturn $2 }
+  | return List(Expr, ',')              { LuaReturn $2 }
   | break                               { LuaBreak }
 
 ElseIfs :: { [(LuaExpr, [LuaStmt])] }

src/Language/Lua/Parser/Token.hs

@@ -140,7 +140,8 @@ instance Show TokenClass where
   show TcEOF = "<eof>"
 
 -- | A token, with its class, start, and end position.
-data Token = Token !TokenClass !SourcePos !SourcePos deriving Show
+data Token = Token !TokenClass !SourcePos !SourcePos
+  deriving (Eq, Show)
 
 instance Spanned Token where
   annotation (Token _ s e) = mkSpanUnsafe s e

src/Language/Lua/Syntax.hs

@@ -103,20 +103,47 @@ assocOf ".." = ARight
 assocOf "^"  = ARight
 assocOf _    = ALeft
 
--- | Emit an indented block of objects, with a header and footer
+contained :: Doc -> [Doc] -> Doc -> Doc
+contained header body footer = header <> nest 2 (line <> vsep body) <> line <> footer
+
+-- | Emit an indented block of statements, with a header and footer
 --
 -- We have this weird asymmetry of 'line' as we need to indent the first line
 -- line of the body but don't want to indent the footer.
-block :: Doc -> [Doc] -> Doc -> Doc
-block header body footer = header <> nest 2 (line <> vsep body) <> line <> footer
+block :: Doc -> [LuaStmt] -> Doc -> Doc
+block header body footer = header <> nest 2 (line <> stmts body) <> line <> footer
+
+stmts :: [LuaStmt] -> Doc
+stmts [] = mempty
+stmts [x] = pretty x
+stmts (a:b:cs)
+  | trailingExpr a && leadingS b = pretty a <> ";" <#> stmts (b:cs)
+  | otherwise = pretty a <#> stmts (b:cs) where
+  trailingExpr LuaAssign{} = True
+  trailingExpr LuaRepeat{} = True
+  trailingExpr LuaReturn{} = True
+  trailingExpr LuaLocal{} = True
+  trailingExpr LuaCallS{} = True
+  trailingExpr _ = False
+
+  leadingS (LuaCallS c) = leadingC c
+  leadingS (LuaAssign (v:_) _) = leadingVar v
+  leadingS _ = False
 
--- | A 'block', which may potentially be simplified to a single line.
-miniBlock :: Doc -> Doc -> Doc -> Doc
-miniBlock header body footer = header <> nest 2 (softline <> body) <> softline <> footer
+  leadingC (LuaCall e _) = leadingFn e
+  leadingC (LuaInvoke e _ _) = leadingFn e
 
+  leadingFn (LuaCallE c) = leadingC c
+  leadingFn (LuaRef LuaName{}) = False
+  leadingFn _ = True
+
+  leadingVar LuaName{} = False
+  leadingVar (LuaIndex (LuaRef v) _) = leadingVar v
+  leadingVar (LuaIndex _ _) = True
+  leadingVar LuaQuoteV{} = False
 
 -- | A variant of 'block' but with an empty footer
-headedBlock :: Doc -> [Doc] -> Doc
+headedBlock :: Doc -> [LuaStmt] -> Doc
 headedBlock header body = block header body empty
 
 -- | Build a series of function arguments
@@ -126,42 +153,42 @@ args = parens . hsep . punctuate comma
 instance Pretty LuaStmt where
   pretty (LuaDo xs) =
     block (keyword "do")
-          (map pretty xs)
+          xs
           (keyword "end")
   pretty (LuaAssign ns xs) = hsep (punctuate comma (map pretty ns)) <+> equals <+> hsep (punctuate comma (map pretty xs))
   pretty (LuaWhile c t) =
     block (keyword "while" <+> pretty c <+> keyword "do")
-          (map pretty t)
+          t
           (keyword "end")
   pretty (LuaRepeat t c) =
     block (keyword "repeat")
-          (map pretty t)
+          t
           (keyword "until" <+> pretty c)
   pretty (LuaIfElse [(c,[t])]) =
-    miniBlock (keyword "if" <+> pretty c <+> keyword "then") (pretty t) (keyword "end")
+    group $ block (keyword "if" <+> pretty c <+> keyword "then") [t] (keyword "end")
   pretty (LuaIfElse ((c,t):bs)) =
     let pprintElse [] = keyword "end"
         pprintElse [(LuaTrue, b)] =
-             headedBlock (keyword "else") (map pretty b)
+             headedBlock (keyword "else") b
           <> keyword "end"
         pprintElse ((c, b):xs) =
              headedBlock (keyword "elseif" <+> pretty c <+> keyword "then")
-                         (map pretty b)
+                         b
           <> pprintElse xs
      in headedBlock (keyword "if" <+> pretty c <+> keyword "then")
-                    (map pretty t)
+                    t
      <> pprintElse bs
   pretty (LuaIfElse []) = error "impossible"
   pretty (LuaFornum v s e i b) =
     block ( keyword "for" <+> pretty v <+> equals
         <+> pretty s <+> comma <+> pretty e <+> comma <+> pretty i <+> keyword "do" )
-          (map pretty b)
+          b
           (keyword "end")
   pretty (LuaFor vs es b) =
     block ( keyword "for" <+> hsep (punctuate comma (map pretty vs))
         <+> keyword "in" <+> hsep (punctuate comma (map pretty es))
         <+> keyword "do" )
-         (map pretty b)
+         b
          (keyword "end")
   pretty (LuaLocalFun n a b) =
     funcBlock (keyword "local function" <+> pretty n <> args (map pretty a))
@@ -172,9 +199,12 @@ instance Pretty LuaStmt where
                         <+> equals <+> hsep (punctuate comma (map pretty xs))
   pretty (LuaQuoteS x) = "@" <> text x
   pretty LuaBreak = keyword "break"
-  pretty (LuaReturn v) = keyword "return" <+> pretty v
+  pretty (LuaReturn []) = keyword "return"
+  pretty (LuaReturn vs) = keyword "return" <+> hsep (punctuate comma (map pretty vs))
   pretty (LuaCallS x) = pretty x
 
+  prettyList = stmts
+
 instance Pretty LuaVar where
   pretty (LuaName x) = text x
   pretty (LuaIndex e (LuaString k))
@@ -206,16 +236,16 @@ instance Pretty LuaExpr where
       op "and" = skeyword "and"
       op "or" = skeyword "or"
       op o = text o
-  pretty e@(LuaUnOp o x) = op o <> prettyWith (precedenceOf e) x where
-    op "not" = skeyword "not "
-    op o = text o
+  pretty e@(LuaUnOp "not" x) = skeyword "not " <> prettyWith (precedenceOf e) x
+  pretty (LuaUnOp "-" x@LuaUnOp{}) = text "-" <> parens (pretty x)
+  pretty e@(LuaUnOp o x) = text o <> prettyWith (precedenceOf e) x
   pretty (LuaRef x) = pretty x
   pretty (LuaFunction a b) =
     funcBlock (keyword "function" <> args (map pretty a))
               b
               (keyword "end")
   pretty (LuaTable []) = lbrace <> rbrace
-  pretty (LuaTable ps) = group (block lbrace (punctuate comma . entries 1 $ ps) rbrace) where
+  pretty (LuaTable ps) = group (contained lbrace (punctuate comma . entries 1 $ ps) rbrace) where
     entries _ [] = []
     entries n ((LuaString k, v):es) | validKey k = text k <+> value v : entries n es
     entries n ((LuaInteger k, v):es) | k == n = pretty v : entries (n + 1) es
@@ -239,8 +269,8 @@ prettyWith desired expr =
 -- | An alternative to 'block' which may group simple functions onto one line
 funcBlock :: Doc -> [LuaStmt] -> Doc -> Doc
 funcBlock header [] = group . block header []
-funcBlock header [r@LuaReturn{}] = group . block header [pretty r]
-funcBlock header body = block header (map pretty body)
+funcBlock header r@[LuaReturn{}] = group . block header r
+funcBlock header body = block header body
 
 validKey :: Text -> Bool
 validKey t = case T.uncons t of

tests/lua/emit_ifs.lua

@@ -3,12 +3,12 @@ do
   local function _amp_amp(a) return function(b) return a and b end end
   local function _bar_bar(a) return function(b) return a or b end end
   local function _not(a) return not a end
-  (nil)({ ands = _amp_amp, ors = _bar_bar, ["not"] = _not })
+  (nil)({ ands = _amp_amp, ors = _bar_bar, ["not"] = _not });
   (nil)(function(tmp)
     if true then return print("L") end
     print("R")
     return print("R")
-  end)
+  end);
   (nil)(function(tmp)
     if not true then return print("R") end
     print("L")