inferno-core-0.1.0.0: test/Parse/Spec.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Parse.Spec where
import Data.Functor.Foldable (ana, project)
import qualified Data.IntMap as IntMap (elems, toList)
import qualified Data.List.NonEmpty as NEList
import Data.Text (Text, pack, unpack)
import qualified Data.Text as Text
import Data.Text.Lazy (toStrict)
-- import Inferno.Module.Prelude (baseOpsTable, builtinModulesOpsTable)
import Inferno.Parse (parseExpr, prettyError)
import Inferno.Types.Syntax
( BlockUtils (removeComments),
Comment (..),
Expr (..),
ExtIdent (..),
Fixity (..),
IStr (..),
Ident (Ident),
ImplExpl (..),
Import (..),
InfixFixity (..),
Lit (..),
ModuleName (..),
Pat (..),
Scoped (..),
SomeIStr (..),
TList (..),
arbitraryName,
tListFromList,
)
import Inferno.Utils.Prettyprinter (renderPretty)
import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe)
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck
( Arbitrary (..),
Gen,
PrintableString (getPrintableString),
Property,
Testable (property),
choose,
counterexample,
genericShrink,
oneof,
recursivelyShrink,
shrinkNothing,
sized,
suchThat,
(===),
)
import Text.Pretty.Simple (pShow)
import Utils (baseOpsTable, builtinModulesOpsTable)
instance Arbitrary a => Arbitrary (Scoped a) where
arbitrary = oneof $ [pure LocalScope, Scope <$> arbitrary]
shrink = shrinkNothing
instance Arbitrary InfixFixity where
arbitrary = oneof $ map pure [NoFix, LeftFix, RightFix]
shrink = shrinkNothing
instance Arbitrary Lit where
arbitrary =
oneof
[ LInt <$> arbitrary,
LDouble <$> arbitrary,
(LText . pack . getPrintableString) <$> arbitrary,
LHex <$> arbitrary
]
instance Arbitrary ImplExpl where
shrink = shrinkNothing
arbitrary =
oneof
[ Impl <$> arbitrary,
Expl <$> arbitrary
]
instance Arbitrary (Import ()) where
shrink = shrinkNothing
arbitrary =
oneof
[ IVar () <$> arbitrary,
IOpVar () <$> arbitrary,
IEnum () () <$> arbitrary
]
instance Arbitrary (Comment ()) where
shrink = shrinkNothing
arbitrary =
oneof
[ (\x -> LineComment () x ()) <$> (pack . getPrintableString <$> arbitrary) `suchThat` (Text.all $ \c -> c /= '\n' && c /= '\r'),
(\x -> BlockComment () x ()) <$> (pack . getPrintableString <$> arbitrary) `suchThat` (Text.all $ \c -> c /= '*') -- prevent having a '*/'
]
instance Arbitrary a => Arbitrary (SomeIStr a) where
arbitrary = sized $ \n -> do
k <- choose (0, n)
oneof [SomeIStr <$> goT k, SomeIStr <$> goF k]
where
goT :: Int -> Gen (IStr 'True a)
goT = \case
0 -> pure ISEmpty
n -> oneof [ISExpr <$> arbitrary <*> goT (n -1), ISExpr <$> arbitrary <*> goF (n -1)]
goF :: Int -> Gen (IStr 'False a)
goF = \case
0 -> ISStr <$> arbitrary <*> pure ISEmpty
n -> ISStr <$> arbitrary <*> goT (n -1)
shrink (SomeIStr ISEmpty) = []
shrink (SomeIStr (ISStr s xs)) =
-- shrink to subterms
[SomeIStr xs]
++
-- recursively shrink subterms
[ case xs' of
SomeIStr (ISStr _ _) -> xs'
SomeIStr r@(ISExpr _ _) -> SomeIStr $ ISStr s r
SomeIStr r@ISEmpty -> SomeIStr $ ISStr s r
| xs' <- shrink (SomeIStr xs)
]
shrink (SomeIStr (ISExpr e xs)) =
[SomeIStr xs]
++ [SomeIStr (ISExpr e' xs) | e' <- shrink e]
++
-- recursively shrink subterms
[SomeIStr (ISExpr e' xs') | (e', SomeIStr xs') <- shrink (e, SomeIStr xs)]
instance Arbitrary (Pat () ()) where
arbitrary = sized arbitrarySizedPat
shrink = recursivelyShrink
arbitrarySizedPat :: Int -> Gen (Pat () ())
arbitrarySizedPat n =
oneof
[ pure $ PVar () Nothing,
PVar () . Just <$> arbitrary,
PEnum () () LocalScope <$> arbitrary,
PLit () <$> arbitrary,
POne () <$> arbitrarySizedPat n,
pure $ PEmpty (),
PCommentAbove <$> arbitrary <*> arbitrarySizedPat (n `div` 3),
PCommentAfter <$> arbitrarySizedPat (n `div` 3) <*> arbitrary,
PCommentBelow <$> arbitrarySizedPat (n `div` 3) <*> arbitrary,
(\xs -> PTuple () (tListFromList xs) ()) <$> do
k <- choose (0, n)
sequence [(,Nothing) <$> arbitrarySizedPat (n `div` 3) | _ <- [1 .. k]]
`suchThat` (\xs -> length xs /= 1)
]
instance Arbitrary e => Arbitrary (NEList.NonEmpty e) where
arbitrary = NEList.fromList <$> (arbitrary `suchThat` (not . null))
shrink = genericShrink
instance Arbitrary (Expr () ()) where
shrink = recursivelyShrink
arbitrary = sized arbitrarySized
where
-- Don't generate implicit variables, because parser does not support them
arbitraryExtIdent = ExtIdent <$> Right <$> arbitraryName
arbitraryImplExpl = oneof [Impl <$> arbitraryExtIdent, Expl <$> arbitraryExtIdent]
arbitraryVar =
oneof
[ Var () () LocalScope <$> arbitraryImplExpl,
OpVar () () LocalScope . Ident
<$> ( oneof $
concatMap
( \case
(InfixOp _, _, op) -> [pure op]
_ -> []
)
$ concat $ IntMap.elems baseOpsTable
)
]
arbitraryEnum = Enum () () LocalScope <$> arbitrary
arbitraryLit = Lit () <$> arbitrary
arbitraryApp n =
App
<$> (arbitrarySized $ n `div` 3)
<*> (arbitrarySized $ n `div` 3)
arbitraryLam n =
(\vs e -> Lam () vs () e)
<$> arbitraryLamVars <*> (arbitrarySized $ n `div` 3)
where
-- Don't generate implicit vars. Sorry, there must be a nicer way to do this
arbitraryLamVars :: Gen (NEList.NonEmpty ((), Maybe ExtIdent))
arbitraryLamVars = arbitrary `suchThat` (all isSomeRight . snd . NEList.unzip)
isSomeRight (Just (ExtIdent (Right _))) = True
isSomeRight _ = False
arbitraryLet n =
(\v e1 e2 -> Let () () v () e1 () e2)
<$> arbitraryImplExpl <*> (arbitrarySized $ n `div` 3) <*> (arbitrarySized $ n `div` 3)
arbitraryIString n =
(\xs -> InterpolatedString () xs ())
<$> do
k <- choose (0, n)
oneof [SomeIStr <$> goT k, SomeIStr <$> goF k]
where
goT :: Int -> Gen (IStr 'True ((), Expr () (), ()))
goT = \case
0 -> pure ISEmpty
m ->
oneof
[ ISExpr <$> ((\x -> ((), x, ())) <$> (arbitrarySized $ n `div` 3)) <*> goT (m -1),
ISExpr <$> ((\x -> ((), x, ())) <$> (arbitrarySized $ n `div` 3)) <*> goF (m -1)
]
goF :: Int -> Gen (IStr 'False ((), Expr () (), ()))
goF = \case
0 ->
ISStr
<$> ( (pack . getPrintableString <$> arbitrary)
`suchThat` (\x -> not (Text.null x) && Text.all (\c -> c /= '\\' && c /= '$' && c /= '`') x)
)
<*> pure ISEmpty
m ->
ISStr
<$> ( (pack . getPrintableString <$> arbitrary)
`suchThat` (\x -> not (Text.null x) && Text.all (\c -> c /= '\\' && c /= '$' && c /= '`') x)
)
<*> goT (m -1)
arbitraryIf n =
(\c t f -> If () c () t () f)
<$> (arbitrarySized $ n `div` 3) <*> (arbitrarySized $ n `div` 3) <*> (arbitrarySized $ n `div` 3)
arbitraryAssert n =
(\c e -> Assert () c () e)
<$> (arbitrarySized $ n `div` 3) <*> (arbitrarySized $ n `div` 3)
arbitraryOp n =
(\(prec, fix, op) e1 e2 -> Op e1 () () (prec, fix) LocalScope (Ident op) e2)
<$> ( oneof $
map pure $
concatMap
( \(prec, xs) ->
concatMap
( \case
(InfixOp fix, _, op) -> [(prec, fix, op)]
_ -> []
)
xs
)
$ IntMap.toList baseOpsTable
)
<*> (arbitrarySized $ n `div` 3)
<*> (arbitrarySized $ n `div` 3)
arbitraryPreOp n =
(\(prec, op) e -> PreOp () () prec LocalScope (Ident op) e)
<$> ( oneof $
map pure $
concatMap
( \(prec, xs) ->
concatMap
( \case
(PrefixOp, _, op) -> [(prec, op)]
_ -> []
)
xs
)
$ IntMap.toList baseOpsTable
)
<*> (arbitrarySized $ n `div` 3)
arbitraryCase n =
(\e cs -> Case () e () (NEList.fromList cs) ())
<$> (arbitrarySized $ n `div` 3)
<*> do
k <- choose (0, n)
sequence
[ (\i e -> ((), i, (), e))
<$> arbitrarySizedPat (n `div` 3) <*> arbitrarySized (n `div` 3)
| _ <- [1 .. k]
]
`suchThat` (not . null)
arbitraryBracketed n = (\e -> Bracketed () e ()) <$> arbitrarySized (n `div` 3)
arbitrarySized 0 =
oneof
[ arbitraryVar,
arbitraryEnum,
arbitraryLit,
pure $ Empty ()
]
arbitrarySized n =
oneof
[ arbitraryVar,
arbitraryEnum,
arbitraryLit,
arbitraryApp n,
arbitraryLam n,
arbitraryLet n,
arbitraryIString n,
arbitraryIf n,
arbitraryOp n,
arbitraryPreOp n,
(\xs -> Array () xs ())
<$> ( do
k <- choose (0, n)
sequence [(,Nothing) <$> arbitrarySized (n `div` 3) | _ <- [1 .. k]]
),
One () <$> arbitrarySized (n `div` 3),
pure $ Empty (),
arbitraryAssert n,
arbitraryCase n,
(\e xs c -> ArrayComp () e () (NEList.fromList [((), x, (), e', Nothing) | (x, e') <- xs]) c ())
<$> (arbitrarySized $ n `div` 3)
<*> do
k <- choose (0, n)
sequence [(,) <$> arbitrary <*> arbitrarySized (n `div` 3) | _ <- [1 .. k]]
`suchThat` (not . null)
<*> oneof [Just . ((),) <$> (arbitrarySized $ n `div` 3), pure Nothing],
arbitraryBracketed n,
CommentAbove <$> arbitrary <*> arbitrarySized (n `div` 3),
CommentAfter <$> arbitrarySized (n `div` 3) <*> arbitrary,
CommentBelow <$> arbitrarySized (n `div` 3) <*> arbitrary
]
normalizePat :: Pat h a -> Pat h a
normalizePat = ana $ \case
PTuple p1 xs p2 -> project $ PTuple p1 (fmap (\(e, _) -> (normalizePat e, Nothing)) xs) p2
x -> project x
normalizeExpr :: Expr h a -> Expr h a
normalizeExpr = ana $ \case
PreOp pos hsh prec LocalScope (Ident "-") e -> case normalizeExpr e of
Lit l' (LInt x) -> project $ Lit l' $ LInt $ - x
Lit l' (LDouble x) -> project $ Lit l' $ LDouble $ - x
PreOp _ _ _ LocalScope (Ident "-") e' -> project $ e'
e' -> project $ PreOp pos hsh prec LocalScope (Ident "-") e'
Tuple p1 xs p2 -> project $ Tuple p1 (fmap (\(e, _) -> (normalizeExpr e, Nothing)) xs) p2
Array p1 xs p2 -> project $ Array p1 (fmap (\(e, _) -> (normalizeExpr e, Nothing)) xs) p2
ArrayComp p1 e_body p2 args e_cond p3 ->
project $
ArrayComp
p1
(normalizeExpr e_body)
p2
(fmap (\(p4, x, p5, e, _) -> (p4, x, p5, normalizeExpr e, Nothing)) args)
(fmap (\(p4, e) -> (p4, normalizeExpr e)) e_cond)
p3
Bracketed _ e _ -> project $ normalizeExpr e
Op e1 p1 h (_, fix) modNm i e2 -> project $ Op (normalizeExpr e1) p1 h (0, fix) modNm i (normalizeExpr e2)
Case p1 e_case p2 patExprs p3 -> project $ Case p1 (normalizeExpr e_case) p2 (fmap (\(p4, p, p5, e) -> (p4, normalizePat p, p5, normalizeExpr e)) patExprs) p3
x -> project x
(<?>) :: (Testable p) => p -> Text -> Property
(<?>) = flip (counterexample . unpack)
infixl 2 <?>
parsingTests :: Spec
parsingTests = describe "pretty printing/parsing" $ do
prop "parseExpr and pretty are inverse up to normalizeExpr" $
\(x :: Expr () ()) -> case parseExpr baseOpsTable builtinModulesOpsTable (renderPretty x) of
Left err ->
property False
<?> ( "Pretty: \n" <> (renderPretty x)
<> "\nParse error:\n"
<> (pack $ prettyError $ fst $ NEList.head err)
)
Right (res, _comments) ->
(normalizeExpr (removeComments x) === normalizeExpr (fmap (const ()) res))
<?> ( "Pretty: \n" <> (renderPretty x)
<> "\nParsed: \n"
<> (toStrict $ pShow res)
<> "\nParsed pretty: \n"
<> (renderPretty res)
)
describe "parsing literals" $ do
shouldSucceedFor "0" $ Lit () (LInt 0)
shouldSucceedFor "0.0" $ Lit () (LDouble 0)
shouldSucceedFor "3" $ Lit () (LInt 3)
shouldSucceedFor "3.1415" $ Lit () (LDouble 3.1415)
shouldSucceedFor "0xff" $ Lit () (LHex 255)
shouldSucceedFor "0Xff" $ Lit () (LHex 255)
shouldSucceedFor "0xFf" $ Lit () (LHex 255)
shouldSucceedFor "0XFF" $ Lit () (LHex 255)
shouldSucceedFor "0x123456789abcdef" $ Lit () (LHex 81985529216486895)
shouldFailFor "0x3.14"
shouldSucceedFor "\"0XFF\"" $ Lit () (LText "0XFF")
shouldSucceedFor "\"0X\\nFF\"" $ Lit () (LText "0X\nFF")
shouldSucceedFor "\"0X\\\\nFF\"" $ Lit () (LText "0X\\nFF")
shouldFailFor "\"0X\nFF\""
describe "parsing interpolated strings" $ do
shouldSucceedFor "``" $ InterpolatedString () (SomeIStr $ ISEmpty) ()
shouldSucceedFor "`hello\nworld`" $ InterpolatedString () (SomeIStr (ISStr "hello\nworld" ISEmpty)) ()
shouldSucceedFor "`${1}`" $ InterpolatedString () (SomeIStr (ISExpr ((), Lit () (LInt 1), ()) ISEmpty)) ()
shouldSucceedFor "`hello\nworld${1}`" $ InterpolatedString () (SomeIStr (ISStr "hello\nworld" (ISExpr ((), Lit () (LInt 1), ()) ISEmpty))) ()
shouldSucceedFor "`hello\nworld${\"!\"}`" $ InterpolatedString () (SomeIStr (ISStr "hello\nworld" (ISExpr ((), Lit () (LText "!"), ()) ISEmpty))) ()
shouldSucceedFor "`hello\nworld${`I am ${\"nested\"}`}`" $
InterpolatedString () (SomeIStr (ISStr "hello\nworld" (ISExpr ((), InterpolatedString () (SomeIStr (ISStr "I am " (ISExpr ((), Lit () (LText "nested"), ()) ISEmpty))) (), ()) ISEmpty))) ()
shouldFailFor "`hello\nworld${}`"
describe "parsing negation" $ do
shouldSucceedFor "-3" $ PreOp () () 19 LocalScope (Ident "-") (Lit () (LInt 3))
shouldSucceedFor "(-3)" $ Bracketed () (PreOp () () 19 LocalScope (Ident "-") (Lit () (LInt 3))) ()
shouldFailFor "--3"
shouldSucceedFor "-x" $ PreOp () () 19 LocalScope (Ident "-") (Var () () LocalScope (Expl (ExtIdent $ Right "x")))
shouldSucceedFor "(-(-x))" $ Bracketed () (PreOp () () 19 LocalScope (Ident "-") (Bracketed () (PreOp () () 19 LocalScope (Ident "-") (Var () () LocalScope (Expl (ExtIdent $ Right "x")))) ())) ()
shouldSucceedFor "5+(-3)" $ Op (Lit () (LInt 5)) () () (9, LeftFix) LocalScope (Ident "+") (Bracketed () (PreOp () () 19 LocalScope (Ident "-") (Lit () (LInt 3))) ())
shouldSucceedFor "5+-3" $ Op (Lit () (LInt 5)) () () (9, LeftFix) LocalScope (Ident "+") (PreOp () () 19 LocalScope (Ident "-") (Lit () (LInt 3)))
shouldSucceedFor "-3+5" $ Op (PreOp () () 19 LocalScope (Ident "-") (Lit () (LInt 3))) () () (9, LeftFix) LocalScope (Ident "+") (Lit () (LInt 5))
shouldSucceedFor "(-3)+5" $ Op (Bracketed () (PreOp () () 19 LocalScope (Ident "-") (Lit () (LInt 3))) ()) () () (9, LeftFix) LocalScope (Ident "+") (Lit () (LInt 5))
describe "parsing variables" $ do
shouldSucceedFor "x" $ Var () () LocalScope (Expl (ExtIdent $ Right "x"))
shouldSucceedFor "A.x" $ Var () () (Scope (ModuleName "A")) (Expl (ExtIdent $ Right "x"))
shouldSucceedFor "x127652" $ Var () () LocalScope (Expl (ExtIdent $ Right "x127652"))
shouldSucceedFor "X12aaAA" $ Var () () LocalScope (Expl (ExtIdent $ Right "X12aaAA"))
shouldSucceedFor "X_12aaAA" $ Var () () LocalScope (Expl (ExtIdent $ Right "X_12aaAA"))
shouldSucceedFor "X__" $ Var () () LocalScope (Expl (ExtIdent $ Right "X__"))
shouldFailFor "_x"
shouldFailFor "let _ = () in ()"
shouldFailFor "let _x = () in ()"
shouldSucceedFor "fun _x -> ()" $ Lam () (((), Nothing) NEList.:| []) () (Tuple () TNil ())
describe "parsing implicit variables" $ do
let letImpl x = Let () () (Impl (ExtIdent $ Right x)) () (Tuple () TNil ()) () (Tuple () TNil ())
shouldSucceedFor "let ?X__ = () in ()" $ letImpl "X__"
shouldSucceedFor "let ?x = () in ()" $ letImpl "x"
shouldSucceedFor "let ?x_y = () in ()" $ letImpl "x_y"
shouldFailFor "let ?_ = () in ()"
shouldFailFor "let ?x-y = () in ()"
describe "parsing tuples" $ do
shouldSucceedFor "()" $ Tuple () TNil ()
shouldSucceedFor "(None, None)" $ Tuple () (TCons (Empty (), Just ()) (Empty (), Nothing) []) ()
shouldSucceedFor "(None)" $ Bracketed () (Empty ()) ()
describe "parsing arrays" $ do
shouldSucceedFor "[]" $ Array () [] ()
shouldSucceedFor "[None, None]" $ Array () [(Empty (), Just ()), (Empty (), Nothing)] ()
describe "parsing infix operators" $ do
shouldSucceedFor "2*3+7/2" $
Op
(Op (Lit () (LInt 2)) () () (10, LeftFix) LocalScope (Ident "*") (Lit () (LInt 3)))
()
()
(9, LeftFix)
LocalScope
(Ident "+")
(Op (Lit () (LInt 7)) () () (10, LeftFix) LocalScope (Ident "/") (Lit () (LInt 2)))
shouldSucceedFor "2*(3+7)/2" $
Op
( Op
(Lit () (LInt 2))
()
()
(10, LeftFix)
LocalScope
(Ident "*")
(Bracketed () (Op (Lit () (LInt 3)) () () (9, LeftFix) LocalScope (Ident "+") (Lit () (LInt 7))) ())
)
()
()
(10, LeftFix)
LocalScope
(Ident "/")
(Lit () (LInt 2))
shouldSucceedFor "2*3*4" $
Op
(Op (Lit () (LInt 2)) () () (10, LeftFix) LocalScope (Ident "*") (Lit () (LInt 3)))
()
()
(10, LeftFix)
LocalScope
(Ident "*")
(Lit () (LInt 4))
-- should this parse or should <,<=,>,>= be the same precedence level as == ?
shouldSucceedFor "2>3==3<2" $
Op
(Op (Lit () (LInt 2)) () () (7, NoFix) LocalScope (Ident ">") (Lit () (LInt 3)))
()
()
(6, NoFix)
LocalScope
(Ident "==")
(Op (Lit () (LInt 3)) () () (7, NoFix) LocalScope (Ident "<") (Lit () (LInt 2)))
shouldFailFor "2==3==4"
describe "parsing case statements" $ do
shouldFailFor "match () with {}"
shouldSucceedFor "match () with { () -> ()}" $ Case () (Tuple () TNil ()) () (((), PTuple () TNil (), (), Tuple () TNil ()) NEList.:| []) ()
shouldSucceedFor "match () with { | () -> ()}" $ Case () (Tuple () TNil ()) () (((), PTuple () TNil (), (), Tuple () TNil ()) NEList.:| []) ()
describe "parsing assertions" $ do
shouldFailFor "assert #false"
shouldSucceedFor "assert #false in ()" $ Assert () (Enum () () LocalScope (Ident "false")) () (Tuple () TNil ())
describe "parsing array builder" $ do
shouldSucceedFor "[() | x <- someList]" $
ArrayComp
()
(Tuple () TNil ())
()
(((), Ident "x", (), Var () () LocalScope (Expl (ExtIdent $ Right "someList")), Nothing) NEList.:| [])
Nothing
()
shouldSucceedFor "[(x,y) | x <- someList, y <- otherList]" $
ArrayComp
()
(Tuple () (TCons (Var () () LocalScope (Expl (ExtIdent $ Right "x")), Just ()) (Var () () LocalScope (Expl (ExtIdent $ Right "y")), Nothing) []) ())
()
(((), Ident "x", (), Var () () LocalScope (Expl (ExtIdent $ Right "someList")), Just ()) NEList.:| [((), Ident "y", (), Var () () LocalScope (Expl (ExtIdent $ Right "otherList")), Nothing)])
Nothing
()
shouldSucceedFor "[2*x | x <- someList, if x > 10]" $
ArrayComp
()
(Op (Lit () (LInt 2)) () () (10, LeftFix) LocalScope (Ident "*") (Var () () LocalScope (Expl (ExtIdent $ Right "x"))))
()
(((), Ident "x", (), Var () () LocalScope (Expl (ExtIdent $ Right "someList")), Just ()) NEList.:| [])
(Just ((), Op (Var () () LocalScope (Expl (ExtIdent $ Right "x"))) () () (7, NoFix) LocalScope (Ident ">") (Lit () (LInt 10))))
()
shouldFailFor "[() | if x > 10]"
where
shouldSucceedFor str ast =
it ("should succeed for \"" <> unpack str <> "\"") $
case parseExpr baseOpsTable builtinModulesOpsTable str of
Left err -> expectationFailure $ "Failed with: " <> (prettyError $ fst $ NEList.head err)
Right (res, _) -> fmap (const ()) res `shouldBe` ast
shouldFailFor str =
it ("should fail for \"" <> unpack str <> "\"") $
case parseExpr baseOpsTable builtinModulesOpsTable str of
Left _err -> pure ()
Right _res -> expectationFailure $ "This should not parse"