diff --git a/rlp.cabal b/rlp.cabal index 5e1b05d..5719560 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -37,6 +37,7 @@ library , Rlp.Parse.Associate , Rlp.Lex , Rlp.Parse.Types + , Rlp.TH , Compiler.Types , Data.Heap , Data.Pretty diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 79b7d8a..5814b58 100644 --- a/src/Compiler/Types.hs +++ b/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)) diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index a885f59..398d7a3 100644 --- a/src/Rlp/Parse.y +++ b/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 diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 93ca70f..e253fdd 100644 --- a/src/Rlp/Parse/Types.hs +++ b/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) + diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index a3dd30c..56dbcd8 100644 --- a/src/Rlp/Syntax.hs +++ b/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] diff --git a/src/Rlp/TH.hs b/src/Rlp/TH.hs index 5f62fe7..eb4d44c 100644 --- a/src/Rlp/TH.hs +++ b/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" + }