stgi-1.1: test/Testsuite/Test/Parser/Parser.hs
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Test.Parser.Parser (tests) where
import Data.Bifunctor
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc
import Stg.Language
import Stg.Language.Prettyprint
import Stg.Parser.Parser
import qualified Stg.Parser.QuasiQuoter as QQ
import Test.Orphans ()
import Test.Tasty
import Test.Tasty.HUnit
tests :: TestTree
tests = testGroup "Hand-written cases"
[ simpleParses
, badParses
, stresstest ]
shouldParseTo
:: Text -- ^ Test name
-> Text -- ^ Parser input
-> Binds -- ^ Expected STG bindings
-> TestTree
shouldParseTo testName input output = testCase (T.unpack testName) test
where
actual = first prettyprintOldAnsi (parse program input)
expected = Right (Program output)
failMessage = case actual of
Left err -> T.unlines
[ "============="
, "Could not parse"
, (T.unlines . map (" > " <>) . T.lines) input
, "Error encountered:"
, (T.unlines . map (" > " <>) . T.lines) err
, "=============" ]
Right r -> (renderPlain :: Doc StgiAnn -> Text) (prettyStgi r)
test = assertEqual (T.unpack failMessage) expected actual
simpleParses :: TestTree
simpleParses = testGroup "Well-written programs"
[ shouldParseTo "Simple binding to boxed literal"
"one = \\ -> Int# 1#"
(Binds [("one", LambdaForm [] NoUpdate []
(AppC "Int#" [AtomLit (Literal 1)]) )])
, shouldParseTo "Constructor application"
"con = \\ -> Maybe b 1#"
(Binds [("con", LambdaForm [] NoUpdate []
(AppC "Maybe"
[AtomVar "b" , AtomLit (Literal 1)] ))])
, shouldParseTo "Bound pattern"
"id = \\ x -> case x of y -> y"
(Binds [("id", LambdaForm [] NoUpdate ["x"]
(Case (AppF "x" [])
(Alts NoNonDefaultAlts
(DefaultBound "y" (AppF "y" []))) ))])
, shouldParseTo "Primitive function application"
"add1 = \\n -> case +# n 1# of n' -> Int# n'"
(Binds [("add1", LambdaForm [] NoUpdate ["n"]
(Case (AppP Add (AtomVar "n") (AtomLit (Literal 1)))
(Alts NoNonDefaultAlts
(DefaultBound "n'" (AppC "Int#" [AtomVar "n'"])))))])
, shouldParseTo "Let"
"a = \\ -> \n\
\ let y = \\(a) x -> Foo x \n\
\ in Con y"
(Binds [("a", LambdaForm [] NoUpdate []
(Let NonRecursive (Binds
[("y", LambdaForm ["a"] NoUpdate ["x"]
(AppC "Foo" [AtomVar "x"]))])
(AppC "Con" [AtomVar "y"])))])
, shouldParseTo "fix"
"fix = \\f -> \n\
\ letrec x = \\(f x) => f x in x"
(Binds
[("fix", LambdaForm [] NoUpdate ["f"]
(Let Recursive
(Binds [("x", LambdaForm ["f","x"] Update []
(AppF "f" [AtomVar "x"]))])
(AppF "x" [])))])
, shouldParseTo "factorial"
"fac = \\n -> \n\
\ case n of \n\
\ 0# -> Int# 1#; \n\
\ default -> case -# n 1# of \n\
\ nMinusOne -> \n\
\ let fac' = \\(nMinusOne) => fac nMinusOne \n\
\ in case fac' of \n\
\ Int# facNMinusOne -> case *# n facNMinusOne of \n\
\ result -> Int# result; \n\
\ err -> Error_fac err "
(Binds
[(Var "fac",LambdaForm [] NoUpdate [Var "n"]
(Case (AppF (Var "n") []) (Alts (PrimitiveAlts
[PrimitiveAlt (Literal 0)
(AppC (Constr "Int#")
[AtomLit (Literal 1)] )])
(DefaultNotBound
(Case (AppP Sub (AtomVar (Var "n")) (AtomLit (Literal 1))) (Alts
NoNonDefaultAlts
(DefaultBound (Var "nMinusOne")
(Let NonRecursive
(Binds
[(Var "fac'",LambdaForm [Var "nMinusOne"] Update []
(AppF (Var "fac") [AtomVar (Var "nMinusOne")]) )])
(Case (AppF (Var "fac'") []) (Alts (AlgebraicAlts
[AlgebraicAlt (Constr "Int#") [Var "facNMinusOne"]
(Case (AppP Mul (AtomVar (Var "n")) (AtomVar (Var "facNMinusOne"))) (Alts
NoNonDefaultAlts
(DefaultBound (Var "result") (AppC (Constr "Int#") [AtomVar (Var "result")])) ))])
(DefaultBound (Var "err") (AppC (Constr "Error_fac") [AtomVar (Var "err")])) ))))))))))])
, shouldParseTo "map with comment"
"-- Taken from the 1992 STG paper, page 21. \n\
\map = \\f xs -> \n\
\ case xs of \n\
\ Nil -> Nil; \n\
\ Cons y ys -> let fy = \\(f y) => f y; \n\
\ mfy = \\(f ys) => map f ys \n\
\ in Cons fy mfy; \n\
\ default -> badListError "
(Binds
[ ("map", LambdaForm [] NoUpdate ["f","xs"]
(Case (AppF "xs" []) (Alts (AlgebraicAlts
[ AlgebraicAlt "Nil" []
(AppC "Nil" [])
, AlgebraicAlt "Cons" ["y","ys"]
(Let NonRecursive
(Binds [ ("fy", LambdaForm ["f","y"] Update []
(AppF "f" [AtomVar "y"]))
, ("mfy", LambdaForm ["f","ys"] Update []
(AppF "map" [AtomVar "f", AtomVar "ys"])) ])
(AppC "Cons" [AtomVar "fy", AtomVar "mfy"])) ])
(DefaultNotBound (AppF "badListError" [])) )))])
, shouldParseTo "map, differently implemented"
"-- Taken from the 1992 STG paper, page 22. \n\
\map = \\f -> \n\
\ letrec mf = \\(f mf) xs -> \n\
\ case xs of \n\
\ Nil -> Nil; \n\
\ Cons y ys -> let fy = \\(f y) => f y; \n\
\ mfy = \\(mf ys) => mf ys \n\
\ in Cons fy mfy; \n\
\ default -> badListError \n\
\ in mf "
(Binds
[ ("map", LambdaForm [] NoUpdate ["f"]
(Let Recursive
(Binds
[ ("mf", LambdaForm ["f","mf"] NoUpdate ["xs"]
(Case (AppF "xs" []) (Alts (AlgebraicAlts
[ AlgebraicAlt "Nil" []
(AppC "Nil" [])
, AlgebraicAlt "Cons" ["y","ys"]
(Let NonRecursive
(Binds
[ ("fy", LambdaForm ["f","y"] Update []
(AppF "f" [AtomVar "y"]))
, ("mfy", LambdaForm ["mf","ys"] Update []
(AppF "mf" [AtomVar "ys"]) )])
(AppC "Cons" [AtomVar "fy", AtomVar "mfy"]) )])
(DefaultNotBound (AppF "badListError" [])) )))])
(AppF "mf" [])))])
]
shouldFailToParse
:: Text -- ^ Test name
-> Text -- ^ Parser input
-> TestTree
shouldFailToParse testName input = testCase (T.unpack testName) test
where
test = case parse program input of
Right ast -> (assertFailure . T.unpack . T.unlines)
[ "Parser should have failed, but succeeded to parse to"
, (T.unlines . map (" > " <>) . T.lines . (renderPlain :: Doc StgiAnn -> Text) . prettyStgi) ast ]
Left _err -> pure ()
badParses :: TestTree
badParses = testGroup "Parsers that should fail"
[ shouldFailToParse "Updatable lambda forms don't take arguments"
"x = \\y => z"
, shouldFailToParse "Standard constructors are not updatable"
"x = \\(y) => Con y"
, shouldFailToParse "Pattern variables have to be unique"
"x = \\ -> case x of Tuple x x -> X; _ -> _"
]
stresstest :: TestTree
stresstest = testGroup "Stress test"
[ shouldParseTo "As few as possible spaces"
"x=\\y->case x of default->z"
[QQ.binds| x = \y -> case x of default -> z |]
, testGroup "Too few spaces"
[ shouldFailToParse "casex of"
"x=\\y->casex of default->z"
, shouldFailToParse "case xof"
"x=\\y->case xof default->z"
, shouldFailToParse "ofdefault"
"x=\\y->case x ofdefault->z"
]
]