rlp TH

src/Rlp/Parse.y

@@ -193,7 +193,10 @@ Con         :: { Located PsName }
 
 {
 
-parseRlpExprR = undefined
+parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs)
+parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
+    where
+        st = programInitState s
 
 parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
 parseRlpProgR s = liftErrorful $ pToErrorful parseRlpProg st

src/Rlp/Parse/Types.hs

@@ -33,6 +33,7 @@ import Control.Monad.State.Strict
 import Control.Monad.Errorful
 import Control.Comonad              (extract)
 import Compiler.RlpcError
+import Language.Haskell.TH.Syntax   (Lift)
 import Data.Text                    (Text)
 import Data.Maybe
 import Data.Fix
@@ -71,6 +72,7 @@ type instance XAppE RlpcPs = ()
 type instance XLitE RlpcPs = ()
 type instance XParE RlpcPs = ()
 type instance XOAppE RlpcPs = ()
+type instance XXRlpExprE RlpcPs = ()
 
 type PsName = Text
 
@@ -275,3 +277,15 @@ initAlexInput s = AlexInput
     , _aiPos        = (1,1,0)
     }
 
+--------------------------------------------------------------------------------
+
+deriving instance Lift (RlpProgram RlpcPs)
+deriving instance Lift (Decl RlpcPs)
+deriving instance Lift (Pat RlpcPs)
+deriving instance Lift (Lit RlpcPs)
+deriving instance Lift (RlpExpr RlpcPs)
+deriving instance Lift (Binding RlpcPs)
+deriving instance Lift (RlpType RlpcPs)
+deriving instance Lift (Alt RlpcPs)
+deriving instance Lift (ConAlt RlpcPs)
+

src/Rlp/Syntax.hs

@@ -51,6 +51,7 @@ import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.Functor.Classes
 import Data.Functor.Identity
 import Data.Kind                    (Type)
+import Language.Haskell.TH.Syntax   (Lift)
 import Lens.Micro
 import Lens.Micro.TH
 import Core.Syntax                  hiding (Lit, Type, Binding, Binding')
@@ -156,7 +157,7 @@ type Decl' p = XRec p (Decl p)
 data Assoc = InfixL
            | InfixR
            | Infix
-           deriving (Show)
+           deriving (Show, Lift)
 
 data ConAlt p = ConAlt (IdP p) [RlpType' p]
 

src/Rlp/TH.hs

@@ -3,4 +3,34 @@ module Rlp.TH
     , rlpExpr
     )
     where
+--------------------------------------------------------------------------------
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Quote
+import Data.Text                        (Text)
+import Data.Text                        qualified as T
+import Control.Monad.IO.Class
+import Control.Monad
+
+import Compiler.RLPC
+import Rlp.Parse
+--------------------------------------------------------------------------------
+
+rlpProg :: QuasiQuoter
+rlpProg = mkqq parseRlpProgR
+
+rlpExpr :: QuasiQuoter
+rlpExpr = mkqq parseRlpExprR
+
+mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
+mkq parse = evalAndParse >=> lift where
+    evalAndParse = liftIO . evalRLPCIO def . parse . T.pack
+
+mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter
+mkqq p = QuasiQuoter
+    { quoteExp = mkq p
+    , quotePat = error "rlp quasiquotes may only be used in expressions"
+    , quoteType = error "rlp quasiquotes may only be used in expressions"
+    , quoteDec = error "rlp quasiquotes may only be used in expressions"
+    }