QuasiQuoter for grin expressions.

grin/grin.cabal

@@ -20,6 +20,7 @@ library
     Eval
     Free
     Grin
+    GrinTH
     TypeEnv
     TypeCheck
     Optimizations
@@ -114,7 +115,10 @@ library
     extra,
     logict,
     QuickCheck,
-    ghc
+    ghc,
+    neat-interpolation,
+    template-haskell
+
   default-language:    Haskell2010
 
 executable grin

grin/src/GrinTH.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE TemplateHaskell #-}
+module GrinTH where
+
+import NeatInterpolation
+import qualified ParseGrin as P
+import qualified Data.Text as T
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+
+def :: QuasiQuoter
+def = text { quoteExp = applyParseDef . quoteExp text }
+
+applyParseDef :: Q Exp -> Q Exp
+applyParseDef q = appE [|P.parseDef|] $ appE [|T.unpack|] q
+
+expr :: QuasiQuoter
+expr = text { quoteExp = applyParseExpr . quoteExp text }
+
+applyParseExpr :: Q Exp -> Q Exp
+applyParseExpr q = appE [|P.parseExpr|] $ appE [|T.unpack|] q

grin/src/ParseGrin.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE TupleSections #-}
 
-module ParseGrin (parseGrin, parseDef) where
+module ParseGrin (parseGrin, parseDef, parseExpr) where
 
 import Data.Void
 import Control.Applicative (empty)
@@ -115,3 +115,6 @@ parseGrin filename content = runParser grinModule filename content
 
 parseDef :: String -> Exp
 parseDef = either (error . show) id . runParser def ""
+
+parseExpr :: String -> Exp
+parseExpr = either (error . show) id . runParser (expr pos1) ""

grin/test/Transformations/Optimising/CaseCopyPropagationSpec.hs

@@ -1,11 +1,13 @@
-{-# LANGUAGE TypeApplications, OverloadedStrings #-}
+{-# LANGUAGE TypeApplications, OverloadedStrings, TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
 module Transformations.Optimising.CaseCopyPropagationSpec where
 
 import Transformations.Optimising.CaseCopyPropagation
 
 import Test.Hspec
-import Free
+import Free hiding (def)
 import Grin
+import GrinTH
 import Test
 import Assertions
 import ParseGrin
@@ -193,29 +195,31 @@ spec = do
 
   it "last expression is a case" $ do
 
-    let before = parseDef $ unlines
-          [ "sum l ="
-          , "  l2 <- eval l"
-          , "  case l2 of"
-          , "    (CNil) -> pure (CInt 0)"
-          , "    (CCons x xs) -> (CInt x') <- eval x"
-          , "                    (CInt s') <- sum xs"
-          , "                    ax' <- _prim_int_add x' s'"
-          , "                    pure (CInt ax')"
-          ]
+    let before =
+          [def|
+            sum l =
+              l2 <- eval l
+              case l2 of
+                (CNil) -> pure (CInt 0)
+                (CCons x xs) -> (CInt x') <- eval x
+                                (CInt s') <- sum xs
+                                ax' <- _prim_int_add x' s'
+                                pure (CInt ax')
+          |]
 
-    let after = parseDef $ unlines
-          [ "sum l ="
-          , "  l2 <- eval l"
-          , "  l2' <- do"
-          , "    case l2 of"
-          , "      (CNil) -> pure 0"
-          , "      (CCons x xs) -> (CInt x') <- eval x"
-          , "                      (CInt s') <- sum xs"
-          , "                      ax' <- _prim_int_add x' s'"
-          , "                      pure ax'"
-          , "  pure (CInt l2')"
-          ]
+    let after =
+          [def|
+            sum l =
+              l2 <- eval l
+              l2' <- do
+                case l2 of
+                  (CNil) -> pure 0
+                  (CCons x xs) -> (CInt x') <- eval x
+                                  (CInt s') <- sum xs
+                                  ax' <- _prim_int_add x' s'
+                                  pure ax'
+              pure (CInt l2')
+          |]
 
     caseCopyPropagation before `sameAs` after