stopping for a bit

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

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
+

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)

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