typechecking things

src/Core/HindleyMilner.hs

@@ -21,6 +21,7 @@ import Lens.Micro.Mtl
 import Lens.Micro.Platform
 import Data.Maybe               (fromMaybe)
 import Data.Text                qualified as T
+import Data.Pretty              (rpretty)
 import Data.HashMap.Strict      qualified as H
 import Data.Foldable            (traverse_)
 import Data.Functor
@@ -59,26 +60,22 @@ instance IsRlpcError TypeError where
         -- todo: use anti-parser instead of show
         TyErrCouldNotUnify t u -> Text
             [ T.pack $ printf "Could not match type `%s` with `%s`."
-                              (show t) (show u)
-            , "Expected: " <> tshow t
-            , "Got: " <> tshow u
+                              (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 error lol"
+            [ T.pack $ printf "Recursive type: `%s' occurs in `%s'"
+                              (rpretty @String t) (rpretty @String x)
             ]
 
-        where tshow = T.pack . show
-
 -- | 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
 
--- TODO: better errors. Errorful-esque, with cummulative errors instead of
--- instantly dying.
-
 -- | Assert that an expression unifies with a given type
 --
 -- >>> let e = [coreProg|3|]
@@ -281,9 +278,3 @@ demoContext =
     , ("False", TyCon "Bool")
     ]
 
-pprintType :: Type -> String
-pprintType (s :-> t) = "(" <> pprintType s <> " -> " <> pprintType t <> ")"
-pprintType TyFun = "(->)"
-pprintType (TyVar x) = x ^. unpacked
-pprintType (TyCon t) = t ^. unpacked
-

src/Core/TH.hs

@@ -40,6 +40,8 @@ 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")
             ]
 
 mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter

src/Data/Pretty.hs

@@ -1,5 +1,6 @@
 module Data.Pretty
     ( Pretty(..)
+    , rpretty
     , ttext
     -- * Pretty-printing lens combinators
     , hsepOf, vsepOf
@@ -12,6 +13,7 @@ module Data.Pretty
 ----------------------------------------------------------------------------------
 import Text.PrettyPrint             hiding ((<>))
 import Text.PrettyPrint.HughesPJ    hiding ((<>))
+import Text.Printf
 import Data.String                  (IsString(..))
 import Data.Text.Lens
 import Data.Monoid
@@ -27,6 +29,9 @@ class Pretty a where
     pretty = prettyPrec 0
     prettyPrec a _ = pretty a
 
+rpretty :: (IsString s, Pretty a) => a -> s
+rpretty = fromString . render . pretty
+
 instance Pretty String where
     pretty = Text.PrettyPrint.text