lift1 fix

src/Rlp/AltParse.y

@@ -2,6 +2,7 @@
 module Rlp.AltParse
     ( parseRlpProg
     , parseRlpProgR
+    , parseRlpExprR
     , runP'
     )
     where
@@ -70,7 +71,7 @@ StandaloneProgram :: { Program Name (RlpExpr PsName) }
 
 
 StandaloneExpr :: { RlpExpr PsName }
-               : litint                  { undefined }
+               : VL Expr VR             { $2 }
 
 VL  :: { () }
 VL  : vlbrace       { () }
@@ -207,6 +208,11 @@ parseRlpProgR s = liftErrorful $ errorful (ma,es)
     where
         (_,es,ma) = runP' parseRlpProg s
 
+parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr PsName)
+parseRlpExprR s = liftErrorful $ errorful (ma,es)
+    where
+        (_,es,ma) = runP' parseRlpExpr s
+
 parseError = error "explode"
 
 }

src/Rlp/AltSyntax.hs

@@ -27,6 +27,7 @@ import Control.Lens
 import Text.Show.Deriving
 import Data.Text                qualified as T
 import Data.Pretty
+import Misc.Lift1
 
 import Compiler.Types
 import Core.Syntax              qualified as Core
@@ -162,3 +163,25 @@ instance (Pretty b) => Pretty1 (Program b) where
 makePrisms ''Pat
 makePrisms ''Binding
 
+deriving instance (Lift b, Lift a) => Lift (Program b a)
+deriving instance (Lift b, Lift a) => Lift (Decl b a)
+deriving instance (Lift b) => Lift (Pat b)
+deriving instance (Lift b) => Lift (DataCon b)
+deriving instance (Lift b) => Lift (Type b)
+
+instance Lift b => Lift1 (Binding b) where
+    liftLift lf (VarB b a) = liftCon2 'VarB (lift b) (lf a)
+
+instance Lift b => Lift1 (Alter b) where
+    liftLift lf (Alter b a) = liftCon2 'Alter (lift b) (lf a)
+
+instance Lift b => Lift1 (ExprF b) where
+    liftLift lf (InfixEF o a b) =
+        liftCon3 'InfixEF (lift o) (lf a) (lf b)
+    liftLift lf (LetEF r bs e) =
+        liftCon3 'LetEF (lift r) bs' (lf e)
+      where bs' = liftLift (liftLift lf) bs
+    liftLift lf (CaseEF e as) =
+        liftCon2 'CaseEF (lf e) as'
+      where as' = liftLift (liftLift lf) as
+

src/Rlp/HindleyMilner.hs

@@ -0,0 +1,56 @@
+module Rlp.HindleyMilner
+    ( infer
+    , check
+    , TypeError(..)
+    , HMError
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Lens             hiding (Context', Context)
+import Control.Monad.Errorful
+import Data.Text                qualified as T
+import Data.Pretty
+import Text.Printf
+
+import Data.Functor
+import Control.Comonad.Cofree
+
+import Compiler.RlpcError
+import Rlp.AltSyntax
+--------------------------------------------------------------------------------
+
+-- | Type error enum.
+data TypeError
+    -- | Two types could not be unified
+    = TyErrCouldNotUnify (Type Name) (Type Name)
+    -- | @x@ could not be unified with @t@ because @x@ occurs in @t@
+    | TyErrRecursiveType Name (Type Name)
+    -- | Untyped, potentially undefined variable
+    | TyErrUntypedVariable Name
+    | TyErrMissingTypeSig Name
+    deriving (Show)
+
+instance IsRlpcError TypeError where
+    liftRlpcError = \case
+        -- todo: use anti-parser instead of show
+        TyErrCouldNotUnify t u -> Text
+            [ T.pack $ printf "Could not match type `%s` with `%s`."
+                              (rpretty @String t) (rpretty @String u)
+            , "Expected: " <> rpretty t
+            , "Got: " <> rpretty u
+            ]
+        TyErrUntypedVariable n -> Text
+            [ "Untyped (likely undefined) variable `" <> n <> "`"
+            ]
+        TyErrRecursiveType t x -> Text
+            [ T.pack $ printf "Recursive type: `%s' occurs in `%s'"
+                              (rpretty @String t) (rpretty @String x)
+            ]
+
+-- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
+-- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
+type HMError = Errorful TypeError
+
+infer = undefined
+check = undefined
+

src/Rlp/TH.hs

@@ -13,16 +13,14 @@ import Control.Monad.IO.Class
 import Control.Monad
 
 import Compiler.RLPC
-import Rlp.Parse
+import Rlp.AltParse
 --------------------------------------------------------------------------------
 
 rlpProg :: QuasiQuoter
-rlpProg = undefined
--- rlpProg = mkqq parseRlpProgR
+rlpProg = mkqq parseRlpProgR
 
 rlpExpr :: QuasiQuoter
-rlpExpr = undefined
--- rlpExpr = mkqq parseRlpExprR
+rlpExpr = mkqq parseRlpExprR
 
 mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
 mkq parse = evalAndParse >=> lift where