diff --git a/src/Core/HindleyMilner.hs b/src/Core/HindleyMilner.hs index d47689b..17d7118 100644 --- a/src/Core/HindleyMilner.hs +++ b/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 - diff --git a/src/Core/TH.hs b/src/Core/TH.hs index 36a3e3f..71f6a7a 100644 --- a/src/Core/TH.hs +++ b/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 diff --git a/src/Data/Pretty.hs b/src/Data/Pretty.hs index f16c319..77337d7 100644 --- a/src/Data/Pretty.hs +++ b/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