core quasiquoter

rlp.cabal

@@ -26,12 +26,14 @@ library
                     , Core.Syntax
                     , Core.Parse
                     , Core.Lex
+                    , Core.TH
 
     -- other-extensions:
     build-depends:    base ^>=4.18.0.0
                     , containers
                     , microlens
                     , microlens-th
+                    , template-haskell
     hs-source-dirs:   src
     default-language: GHC2021
 

src/Control/Parser.hs

@@ -62,6 +62,11 @@ instance (MonadFail m) => MonadFail (ParserT i m) where
 
 ----------------------------------------------------------------------------------
 
+eof :: (MonadPlus m) => ParserT [a] m ()
+eof = ParserT $ \case
+    [] -> pure ([], ())
+    _  -> empty
+
 -- TODO: generalise to non-lists
 satisfy :: (MonadPlus m) => (a -> Bool) -> ParserT [a] m a
 satisfy p = ParserT $ \case

src/Core/Parse.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase, BlockArguments #-}
 module Core.Parse
     ( parseCore
+    , parseCoreExpr
     )
     where
 ----------------------------------------------------------------------------------
@@ -15,6 +16,9 @@ type CoreParser = ParserT [CoreToken] Result
 parseCore :: [CoreToken] -> Result Program
 parseCore = fmap snd . runParserT program
 
+parseCoreExpr :: [CoreToken] -> Result Expr
+parseCoreExpr = fmap snd . runParserT expr
+
 program :: CoreParser Program
 program = Program <$> termMany (char TokSemicolon) scdef
 

src/Core/Syntax.hs

@@ -18,9 +18,10 @@ module Core.Syntax
 ----------------------------------------------------------------------------------
 import Data.Coerce
 import Data.Pretty
-import Data.List            (intersperse)
-import Data.Function        ((&))
+import Data.List                    (intersperse)
+import Data.Function                ((&))
 import Data.String
+import Language.Haskell.TH.Syntax   (Lift)
 ----------------------------------------------------------------------------------
 
 data Expr = Var Name
@@ -30,14 +31,14 @@ data Expr = Var Name
           | Lam [Name] Expr
           | App Expr Expr
           | IntE Int
-          deriving Show
+          deriving (Show, Lift)
 
 infixl 2 :$
 pattern (:$) :: Expr -> Expr -> Expr
 pattern f :$ x = App f x
 
 data Binding = Binding Name Expr
-    deriving Show
+    deriving (Show, Lift)
 
 infixl 1 :=
 pattern (:=) :: Name -> Expr -> Binding
@@ -45,18 +46,18 @@ pattern k := v = Binding k v
 
 data Rec = Rec
          | NonRec
-         deriving (Show, Eq)
+         deriving (Show, Eq, Lift)
 
 data Alter = Alter Int [Name] Expr
-    deriving Show
+    deriving (Show, Lift)
 
 type Name = String
 
 data ScDef = ScDef Name [Name] Expr
-    deriving (Show)
+    deriving (Show, Lift)
 
 newtype Program = Program [ScDef]
-    deriving (Show)
+    deriving (Show, Lift)
 
 instance IsString Expr where
     fromString = Var

src/Core/TH.hs

@@ -0,0 +1,39 @@
+module Core.TH
+    ( coreExpr
+    , core
+    )
+    where
+----------------------------------------------------------------------------------
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Quote
+import Core.Parse
+import Core.Lex
+----------------------------------------------------------------------------------
+
+core :: QuasiQuoter
+core = QuasiQuoter
+    { quoteExp = qCore
+    , quotePat = error "core quasiquotes may only be used in expressions"
+    , quoteType = error "core quasiquotes may only be used in expressions"
+    , quoteDec = error "core quasiquotes may only be used in expressions"
+    }
+
+coreExpr :: QuasiQuoter
+coreExpr = QuasiQuoter
+    { quoteExp = qCoreExpr
+    , quotePat = error "core quasiquotes may only be used in expressions"
+    , quoteType = error "core quasiquotes may only be used in expressions"
+    , quoteDec = error "core quasiquotes may only be used in expressions"
+    }
+
+qCore :: String -> Q Exp
+qCore s = case lexCore s >>= parseCore of
+    Success a -> lift a
+    Error e _ _ -> error e
+
+qCoreExpr :: String -> Q Exp
+qCoreExpr s = case lexCore s >>= parseCoreExpr of
+    Success a -> lift a
+    Error e _ _ -> error e
+