Merge pull request #70 from grin-compiler/32-tests-ctx-based

Extended syntax: added context-based testing

Author: csabahruska

grin/grin.cabal

@@ -137,6 +137,7 @@ library
     Test.ExtendedSyntax.Assertions
     Test.ExtendedSyntax.Old.Grammar
     Test.ExtendedSyntax.Old.Test
+    Test.ExtendedSyntax.New.Test
     Test.ExtendedSyntax.Util
 
     Transformations.ExtendedSyntax.BindNormalisation

grin/src/Grin/ExtendedSyntax/Grin.hs

@@ -105,5 +105,6 @@ concatPrograms prgs = Program (nub $ concat exts) (concat defs) where
 allowedSpecial :: String
 allowedSpecial = "._':!-"
 
+-- QUESTION: Should upper-case letters be allowed?
 allowedInitial :: String
 allowedInitial = "._" ++ ['a'..'z'] ++ ['A'..'Z']

grin/src/Grin/ExtendedSyntax/Parse/AST.hs

@@ -128,10 +128,10 @@ parseProg :: Text -> Exp
 parseProg src = either (error . parseErrorPretty' src) id . parseGrin "" $ withoutTypeAnnots src
 
 parseDef :: Text -> Exp
-parseDef src = either (error . parseErrorPretty' src) id . runParser def "" $ withoutTypeAnnots src
+parseDef src = either (error . parseErrorPretty' src) id . runParser (def <* sc <* eof) "" $ withoutTypeAnnots src
 
 parseExpr :: Text -> Exp
-parseExpr src = either (error . parseErrorPretty' src) id . runParser (expr pos1) "" $ withoutTypeAnnots src
+parseExpr src = either (error . parseErrorPretty' src) id . runParser (expr pos1 <* sc <* eof) "" $ withoutTypeAnnots src
 
 
 withoutTypeAnnots :: Text -> Text

grin/src/Test/ExtendedSyntax/New/Test.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE QuasiQuotes, ViewPatterns #-}
+module Test.ExtendedSyntax.New.Test where
+
+import Data.Text (Text, pack)
+import Data.Bifunctor (second)
+
+import Control.Monad (forM_, forM)
+
+import Test.Hspec (Spec, describe)
+
+import Grin.ExtendedSyntax.TH (expr)
+import Grin.ExtendedSyntax.Grin (Exp, Name)
+import Grin.ExtendedSyntax.TypeEnv (TypeEnv, emptyTypeEnv)
+import Grin.ExtendedSyntax.Pretty (Pretty, PP(..))
+
+import Transformations.ExtendedSyntax.Names (evalNameM, deriveNewName)
+
+type SpecWithProg = Exp -> Spec
+
+type TestExpContext = (String, (TypeEnv, Exp) -> (TypeEnv, Exp))
+
+testExprContext :: (((TypeEnv, Exp) -> (TypeEnv, Exp)) -> Spec) -> Spec
+testExprContext mkSpec = forM_ contexts $ \(label, ctx) -> describe (concat ["(", label, ")"]) $ mkSpec ctx
+
+testExprContextE :: ((Exp -> Exp) -> Spec) -> Spec
+testExprContextE mkSpec =
+  forM_ contexts $ \(label, ctx) ->
+    describe (concat ["(", label, ")"]) $ mkSpec (\e -> snd $ ctx (emptyTypeEnv, e))
+
+contexts :: [TestExpContext]
+contexts =
+  [ emptyCtx
+  , lastBindR
+  , bindL
+  , lastBindL
+  , firstAlt
+  , middleAlt
+  , lastAlt
+  ]
+
+emptyCtx :: TestExpContext
+emptyCtx = ("empty", id)
+
+-- NOTE: These contexts contain some names. Make sure not to use these in your test code!
+
+deriveNames :: Exp -> [Name]
+deriveNames e = fst <$> evalNameM e $ do
+  forM [1..] $ \_ -> deriveNewName "ctxVar"
+
+deriveNamesAsText :: Exp -> [Text]
+deriveNamesAsText = map toText . deriveNames
+
+toText :: Pretty a => a -> Text
+toText = pack . show . PP
+
+bindL :: TestExpContext
+bindL = ("bind left", second tr) where
+  tr e
+    | (v:_) <- deriveNamesAsText e
+    , eText <- toText e = [expr|
+      $v <- do
+        $eText
+      pure ()
+    |]
+
+lastBindL :: TestExpContext
+lastBindL = ("last bind left", second tr) where
+  tr e
+    | (v1:v2:_) <- deriveNamesAsText e
+    , eText <- toText e = [expr|
+      $v1 <- do
+        $v2 <- pure ()
+        $eText
+      pure ()
+    |]
+
+firstAlt :: TestExpContext
+firstAlt = ("first alt", second tr) where
+  tr e
+    | (scrut:v1:v2:v3:x:_) <- deriveNamesAsText e
+    , eText <- toText e = [expr|
+      $scrut <- pure 1
+      case $scrut of
+        1 @ $v1 ->
+          $x <- pure ()
+          $eText
+        2 @ $v2 ->
+          pure ()
+        3 @ $v3 ->
+          pure ()
+    |]
+
+middleAlt :: TestExpContext
+middleAlt = ("middle alt", second tr) where
+  tr e
+    | (scrut:v1:v2:v3:x:_) <- deriveNamesAsText e
+    , eText <- toText e = [expr|
+      $scrut <- pure 1
+      case $scrut of
+        1 @ $v1 ->
+          pure ()
+        2 @ $v2 ->
+          $x <- pure ()
+          $eText
+        3 @ $v3 ->
+          pure ()
+    |]
+
+lastAlt :: TestExpContext
+lastAlt = ("last alt", second tr) where
+  tr e
+    | (scrut:v1:v2:v3:x:_) <- deriveNamesAsText e
+    , eText <- toText e = [expr|
+      $scrut <- pure 1
+      case $scrut of
+        1 @ $v1 ->
+          pure ()
+        2 @ $v2 ->
+          pure ()
+        3 @ $v3 ->
+          $x <- pure ()
+          $eText
+    |]
+
+lastBindR :: TestExpContext
+lastBindR = ("last bind right", second tr) where
+  tr e
+    | (v:_) <- deriveNamesAsText e
+    , eText <- toText e = [expr|
+      $v <- pure ()
+      $eText
+    |]

grin/src/Test/ExtendedSyntax/Util.hs

@@ -5,11 +5,19 @@ module Test.ExtendedSyntax.Util where
 
 import System.FilePath
 
+import Data.Set (Set)
+import Data.Map (Map)
+import Data.Vector (Vector)
 import Data.Text (Text)
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import qualified Data.Vector as V
 import qualified Data.Text.IO as T (readFile)
 
 import Grin.ExtendedSyntax.Grin
 import Grin.ExtendedSyntax.Parse
+import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result as HPT
 
 import Test.Hspec
 import Test.ExtendedSyntax.Assertions
@@ -56,6 +64,30 @@ cNope = Tag C "Nope"
 cNopeH :: Tag
 cNopeH = Tag C "NopeH"
 
+loc :: HPT.Loc -> TypeSet
+loc = tySetFromTypes . pure . HPT.T_Location
+
+unspecLoc :: TypeSet
+unspecLoc = tySetFromTypes [HPT.T_UnspecifiedLocation]
+
+mkNode :: [[HPT.SimpleType]] -> Vector (Set HPT.SimpleType)
+mkNode = V.fromList . map Set.fromList
+
+mkNodeSet :: [(Tag, [[HPT.SimpleType]])] -> NodeSet
+mkNodeSet = HPT.NodeSet . Map.fromList . map (\(t,v) -> (t,mkNode v))
+
+mkTySet :: [(Tag, [[HPT.SimpleType]])] -> TypeSet
+mkTySet = tySetFromNodeSet . mkNodeSet
+
+tySetFromNodeSet :: NodeSet -> TypeSet
+tySetFromNodeSet = TypeSet mempty
+
+tySetFromTypes :: [HPT.SimpleType] -> TypeSet
+tySetFromTypes = flip TypeSet mempty . Set.fromList
+
+mkSimpleMain :: HPT.SimpleType -> (TypeSet, Vector TypeSet)
+mkSimpleMain t = (tySetFromTypes [t], mempty)
+
 -- name ~ name of the test case, and also the grin source file
 mkBeforeAfterTestCase :: String ->
                          FilePath ->

grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs

@@ -36,14 +36,6 @@ spec = do
       calcHPTResultWithCBy = _hptResult . calcCByResult
       mkProducerSet = ProducerSet . M.fromList . map (\(t,xs) -> (t,S.fromList xs))
       emptyProducerSet = mkProducerSet []
-      unspecLoc = tySetFromTypes [T_UnspecifiedLocation]
-      loc = tySetFromTypes . pure . T_Location
-      mkNode = V.fromList . map S.fromList
-      mkNodeSet = HPT.NodeSet . M.fromList . map (\(t,v) -> (t,mkNode v))
-      mkTySet = tySetFromNodeSet . mkNodeSet
-      tySetFromNodeSet = TypeSet mempty
-      tySetFromTypes = flip TypeSet mempty . S.fromList
-      mkSimpleMain t = (tySetFromTypes [t], mempty)
 
   describe "Created-By producers are calculated correctly for" $ do
     it "pures" $ do