ES: added name generation to context-based testing

Author: Anabra

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

@@ -4,14 +4,16 @@ module Test.ExtendedSyntax.New.Test where
 import Data.Text (Text, pack)
 import Data.Bifunctor (second)
 
-import Control.Monad (forM_)
+import Control.Monad (forM_, forM)
 
 import Test.Hspec (Spec, describe)
 
 import Grin.ExtendedSyntax.TH (expr)
-import Grin.ExtendedSyntax.Grin (Exp)
+import Grin.ExtendedSyntax.Grin (Exp, Name)
 import Grin.ExtendedSyntax.TypeEnv (TypeEnv, emptyTypeEnv)
-import Grin.ExtendedSyntax.Pretty (PP(..))
+import Grin.ExtendedSyntax.Pretty (Pretty, PP(..))
+
+import Transformations.ExtendedSyntax.Names (evalNameM, deriveNewName)
 
 type SpecWithProg = Exp -> Spec
 
@@ -29,8 +31,8 @@ contexts :: [TestExpContext]
 contexts =
   [ emptyCtx
   , lastBindR
-  , bindL 0
-  , lastBindL 0
+  , bindL
+  , lastBindL
   , firstAlt
   , middleAlt
   , lastAlt
@@ -39,71 +41,92 @@ contexts =
 emptyCtx :: TestExpContext
 emptyCtx = ("empty", id)
 
-bindL :: Int -> TestExpContext
-bindL (pack . show -> n) = ("bind left", second tr) where
-  tr (exprText -> e) = [expr|
-      fb$n <- do
-        $e
+-- 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 :: Int -> TestExpContext
-lastBindL (pack . show -> n) = ("last bind left", second tr) where
-  tr (exprText -> e) = [expr|
-      md$n <- do
-        __1 <- pure ()
-        $e
+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 (exprText -> e) = [expr|
-      __1 <- pure 1
-      case __1 of
-        1 @ __2 ->
-          __x <- pure ()
-          $e
-        2 @ __3 ->
+  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 @ __4 ->
+        3 @ $v3 ->
           pure ()
     |]
 
 middleAlt :: TestExpContext
 middleAlt = ("middle alt", second tr) where
-  tr (exprText -> e) = [expr|
-      __1 <- pure 1
-      case __1 of
-        1 @ __2 ->
+  tr e
+    | (scrut:v1:v2:v3:x:_) <- deriveNamesAsText e
+    , eText <- toText e = [expr|
+      $scrut <- pure 1
+      case $scrut of
+        1 @ $v1 ->
           pure ()
-        2 @ __3 ->
-          __x <- pure ()
-          $e
-        3 @ __4 ->
+        2 @ $v2 ->
+          $x <- pure ()
+          $eText
+        3 @ $v3 ->
           pure ()
     |]
 
 lastAlt :: TestExpContext
 lastAlt = ("last alt", second tr) where
-  tr (exprText -> e) = [expr|
-      __1 <- pure 1
-      case __1 of
-        1 @ __2 ->
+  tr e
+    | (scrut:v1:v2:v3:x:_) <- deriveNamesAsText e
+    , eText <- toText e = [expr|
+      $scrut <- pure 1
+      case $scrut of
+        1 @ $v1 ->
           pure ()
-        2 @ __3 ->
+        2 @ $v2 ->
           pure ()
-        3 @ __4 ->
-          __x <- pure ()
-          $e
+        3 @ $v3 ->
+          $x <- pure ()
+          $eText
     |]
 
 lastBindR :: TestExpContext
 lastBindR = ("last bind right", second tr) where
-  tr (exprText -> e) = [expr|
-      __1 <- pure ()
-      $e
+  tr e
+    | (v:_) <- deriveNamesAsText e
+    , eText <- toText e = [expr|
+      $v <- pure ()
+      $eText
     |]
-
-exprText :: Exp -> Text
-exprText = pack . show . PP