From a582cd9fcfc5d7c86e4e4fb9102cf7ae9e24f597 Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Thu, 22 Feb 2024 15:56:00 -0700
Subject: [PATCH] stopping for a bit

---
 src/Core/Parse.y        | 24 ++++++++++++++----------
 src/Core/Parse/Types.hs |  9 +++++++++
 src/Core/Syntax.hs      |  3 ++-
 src/Core/TH.hs          |  8 +++++---
 4 files changed, 30 insertions(+), 14 deletions(-)

diff --git a/src/Core/Parse.y b/src/Core/Parse.y
index 89111f6..8ee5626 100644
--- a/src/Core/Parse.y
+++ b/src/Core/Parse.y
@@ -120,7 +120,7 @@ Type            :: { Kind -> Type }
 
 Type1           :: { Kind -> Type }
 Type1           : '(' Type ')'                  { $2 }
-                | varname                       { \k -> TyVar $ MkVar $1 k }
+                | varname                       { \k -> TyVar $1 }
                 | conname                       { \k -> TyCon $ MkTyCon $1 k }
 
 ParList         :: { [PsName] }
@@ -229,13 +229,19 @@ parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m (Expr Var)
 parseCoreExprR = liftMaybe . snd . flip runP def . parseCoreExpr
 
 parseCoreProgR :: forall m. (Monad m)
-               => [Located CoreToken] -> RLPCT m (Program PsName)
-parseCoreProgR s = ddumpast =<< (liftMaybe . snd $ runP (parseCoreProg s) def)
-    where
-        ddumpast :: (Program PsName) -> RLPCT m (Program PsName)
-        ddumpast p = do
-            addDebugMsg "dump-parsed-core" . show $ p
-            pure p
+               => [Located CoreToken] -> RLPCT m (Program Var)
+parseCoreProgR s = do
+    let p = runP (parseCoreProg s) def
+    case p of
+        (st, Just a) -> do
+            let a' = finishTyping st a
+            ddumpast a'
+            pure a'
+  where
+    ddumpast :: Show a => Program a -> RLPCT m (Program a)
+    ddumpast p = do
+        addDebugMsg "dump-parsed-core" . show $ p
+        pure p
 
 happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
 happyBind m k = m >>= k
@@ -255,7 +261,5 @@ doTLPragma (Pragma pr) p = case pr of
 readt :: (Read a) => Text -> a
 readt = read . T.unpack
 
-type PsName = Either Name Var
-
 }
 
diff --git a/src/Core/Parse/Types.hs b/src/Core/Parse/Types.hs
index 564fa76..7a84bcb 100644
--- a/src/Core/Parse/Types.hs
+++ b/src/Core/Parse/Types.hs
@@ -3,6 +3,8 @@ module Core.Parse.Types
     ( P(..)
     , psTyVars
     , def
+    , PsName
+    , finishTyping
     )
     where
 --------------------------------------------------------------------------------
@@ -47,3 +49,10 @@ instance Default PState where
 
 makeLenses ''PState
 
+type PsName = Either Name Var
+
+--------------------------------------------------------------------------------
+
+finishTyping :: PState -> Program PsName -> Program Var
+finishTyping = undefined
+
diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs
index 4b511ad..5de4488 100644
--- a/src/Core/Syntax.hs
+++ b/src/Core/Syntax.hs
@@ -75,7 +75,7 @@ data ExprF b a = VarF Name
 type Expr b = Fix (ExprF b)
 
 data Type = TyFun
-          | TyVar Var
+          | TyVar Name
           | TyApp Type Type
           | TyCon TyCon
           | TyForall Var Type
@@ -369,6 +369,7 @@ instance Lift b => Lift1 (ExprF b) where
     lift1 (CaseF e as)  = liftCon2 'CaseF (lift e) (lift as)
     lift1 (TypeF t)     = liftCon 'TypeF (lift t)
     lift1 (LitF l)      = liftCon 'LitF (lift l)
+    lift1 (ConF t a)    = liftCon2 'ConF (lift t) (lift a)
 
 deriving instance (Show b, Show a) => Show (ExprF b a)
 deriving instance Show b => Show (Binding b)
diff --git a/src/Core/TH.hs b/src/Core/TH.hs
index 71f6a7a..42d7c06 100644
--- a/src/Core/TH.hs
+++ b/src/Core/TH.hs
@@ -39,9 +39,11 @@ coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 coreExprT :: QuasiQuoter
 coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g
     where
-        g = [ ("+#", TyCon "Int#" :-> TyCon "Int#" :-> TyCon "Int#")
-            , ("id", TyCon "a" :-> TyCon "a")
-            , ("fix", (TyCon "a" :-> TyCon "a") :-> TyCon "a")
+        g = [ ("+#", TyInt :-> TyInt :-> TyInt)
+            , ("id", TyForall (MkVar "a" TyKindType) $
+                    TyVar "a" :-> TyVar "a")
+            , ("fix", TyForall (MkVar "a" TyKindType) $
+                    (TyVar "a" :-> TyVar "a") :-> TyVar "a")
             ]
 
 mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter