From 17d764c2ec9eefd75d1b21f91b9f1298239b2c1f Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Fri, 9 Feb 2024 18:31:37 -0700
Subject: [PATCH] typed coreExpr quoter

---
 src/Control/Monad/Utils.hs |  5 +++++
 src/Core/HindleyMilner.hs  | 10 +++++++---
 src/Core/Parse.y           |  8 +++++---
 src/Core/TH.hs             | 19 ++++++++++++-------
 4 files changed, 29 insertions(+), 13 deletions(-)

diff --git a/src/Control/Monad/Utils.hs b/src/Control/Monad/Utils.hs
index 60681e3..d09e91a 100644
--- a/src/Control/Monad/Utils.hs
+++ b/src/Control/Monad/Utils.hs
@@ -1,11 +1,13 @@
 module Control.Monad.Utils
     ( mapAccumLM
     , Kendo(..)
+    , generalise
     )
     where
 ----------------------------------------------------------------------------------
 import Data.Tuple               (swap)
 import Data.Coerce
+import Data.Functor.Identity
 import Control.Monad.State
 import Control.Monad
 ----------------------------------------------------------------------------------
@@ -30,3 +32,6 @@ instance (Monad m) => Semigroup (Kendo m a) where
 instance (Monad m) => Monoid (Kendo m a) where
     mempty = Kendo pure
 
+generalise :: (Monad m) => Identity a -> m a
+generalise (Identity a) = pure a
+
diff --git a/src/Core/HindleyMilner.hs b/src/Core/HindleyMilner.hs
index 9fa3208..d47689b 100644
--- a/src/Core/HindleyMilner.hs
+++ b/src/Core/HindleyMilner.hs
@@ -10,6 +10,7 @@ module Core.HindleyMilner
     , check
     , checkCoreProg
     , checkCoreProgR
+    , checkCoreExprR
     , TypeError(..)
     , HMError
     )
@@ -30,7 +31,7 @@ import Compiler.RlpcError
 import Control.Monad            (foldM, void, forM)
 import Control.Monad.Errorful
 import Control.Monad.State
-import Control.Monad.Utils      (mapAccumLM)
+import Control.Monad.Utils      (mapAccumLM, generalise)
 import Text.Printf
 import Core.Syntax
 ----------------------------------------------------------------------------------
@@ -113,8 +114,11 @@ checkCoreProgR p = (hoistRlpcT generalise . liftE . checkCoreProg $ p)
     where
         liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
 
-        generalise :: forall a. Identity a -> m a
-        generalise (Identity a) = pure a
+checkCoreExprR :: (Monad m) => Context' -> Expr' -> RLPCT m Expr'
+checkCoreExprR g e = (hoistRlpcT generalise . liftE . infer g $ e)
+                  $> e
+    where
+        liftE = liftErrorful . mapErrorful (errorMsg (SrcSpan 0 0 0 0))
 
 -- | Infer the type of an expression under some context.
 --
diff --git a/src/Core/Parse.y b/src/Core/Parse.y
index 3d119cf..fcb6e2c 100644
--- a/src/Core/Parse.y
+++ b/src/Core/Parse.y
@@ -7,6 +7,7 @@ Description : Parser for the Core language
 module Core.Parse
     ( parseCore
     , parseCoreExpr
+    , parseCoreExprR
     , parseCoreProg
     , parseCoreProgR
     , module Core.Lex -- temp convenience
@@ -16,6 +17,7 @@ module Core.Parse
     where
 
 import Control.Monad        ((>=>))
+import Control.Monad.Utils  (generalise)
 import Data.Foldable        (foldl')
 import Data.Functor.Identity
 import Core.Syntax
@@ -226,12 +228,12 @@ insScDef sc = programScDefs %~ (sc:)
 singletonScDef :: (Hashable b) => ScDef b -> Program b
 singletonScDef sc = insScDef sc mempty
 
+parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m Expr'
+parseCoreExprR = hoistRlpcT generalise . parseCoreExpr
+
 parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program'
 parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
     where
-        generalise :: forall a. Identity a -> m a
-        generalise (Identity a) = pure a
-
         ddumpast :: Program' -> RLPCT m Program'
         ddumpast p = do
             addDebugMsg "dump-parsed-core" . show $ p
diff --git a/src/Core/TH.hs b/src/Core/TH.hs
index 8031314..36a3e3f 100644
--- a/src/Core/TH.hs
+++ b/src/Core/TH.hs
@@ -5,6 +5,7 @@ Description : Core quasiquoters
 module Core.TH
     ( coreExpr
     , coreProg
+    , coreExprT
     , coreProgT
     )
     where
@@ -22,20 +23,26 @@ import Data.Text                    qualified as T
 import Core.Parse
 import Core.Lex
 import Core.Syntax
-import Core.HindleyMilner           (checkCoreProgR)
+import Core.HindleyMilner           (checkCoreProgR, checkCoreExprR)
 ----------------------------------------------------------------------------------
 
 coreProg :: QuasiQuoter
 coreProg = mkqq $ lexCoreR >=> parseCoreProgR
 
 coreExpr :: QuasiQuoter
-coreExpr = mkqq $ lexCoreR >=> parseCoreExpr
+coreExpr = mkqq $ lexCoreR >=> parseCoreExprR
 
 -- | Type-checked @coreProg@
 coreProgT :: QuasiQuoter
 coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-mkqq :: (Lift a) => (Text -> RLPC a) -> QuasiQuoter
+coreExprT :: QuasiQuoter
+coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g
+    where
+        g = [ ("+#", TyCon "Int#" :-> TyCon "Int#" :-> TyCon "Int#")
+            ]
+
+mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter
 mkqq p = QuasiQuoter
     { quoteExp = mkq p
     , quotePat = error "core quasiquotes may only be used in expressions"
@@ -43,8 +50,6 @@ mkqq p = QuasiQuoter
     , quoteDec = error "core quasiquotes may only be used in expressions"
     }
 
-mkq :: (Lift a) => (Text -> RLPC a) -> String -> Q Exp
-mkq parse s = case evalRLPC def (parse $ T.pack s) of
-    (Just a,  _) -> lift a
-    (Nothing, _) -> error "todo: aaahhbbhjhbdjhabsjh"
+mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
+mkq parse s = liftIO $ evalRLPCIO def (parse $ T.pack s) >>= lift