rlp TH

rlp.cabal

@@ -37,6 +37,7 @@ library
                     , Rlp.Parse.Associate
                     , Rlp.Lex
                     , Rlp.Parse.Types
+                    , Rlp.TH
                     , Compiler.Types
                     , Data.Heap
                     , Data.Pretty

src/Compiler/Types.hs

@@ -15,11 +15,12 @@ import Control.Comonad
 import Data.Functor.Apply
 import Data.Functor.Bind
 import Control.Lens             hiding ((<<~))
+import Language.Haskell.TH.Syntax   (Lift)
 --------------------------------------------------------------------------------
 
 -- | Token wrapped with a span (line, column, absolute, length)
 data Located a = Located SrcSpan a
-    deriving (Show, Functor)
+    deriving (Show, Lift, Functor)
 
 instance Apply Located where
     liftF2 f (Located sa p) (Located sb q)
@@ -39,7 +40,7 @@ data SrcSpan = SrcSpan
     !Int -- ^ Column
     !Int -- ^ Absolute
     !Int -- ^ Length
-    deriving Show
+    deriving (Show, Lift)
 
 tupling :: Iso' SrcSpan (Int, Int, Int, Int)
 tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))

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"
+    }