feat: beautify type variables on unification failure (#1167)

* feat: beautify type variables on unification failure

Co-authored-by: jacereda <jacereda@gmail.com>

* refactor: reorganize functions to avoid orphan instances

Co-authored-by: jacereda <jacereda@gmail.com>

src/AssignTypes.hs

@@ -65,19 +65,3 @@ beautifyTypeVariables root =
               (map (VarTy . (: [])) ['a' ..])
           )
    in assignTypes mappings root
-
-typeVariablesInOrderOfAppearance :: Ty -> [Ty]
-typeVariablesInOrderOfAppearance (FuncTy argTys retTy ltTy) =
-  concatMap typeVariablesInOrderOfAppearance argTys ++ typeVariablesInOrderOfAppearance retTy ++ typeVariablesInOrderOfAppearance ltTy
-typeVariablesInOrderOfAppearance (StructTy n typeArgs) =
-  case n of
-    t@(VarTy _) -> typeVariablesInOrderOfAppearance t ++ concatMap typeVariablesInOrderOfAppearance typeArgs
-    _ -> concatMap typeVariablesInOrderOfAppearance typeArgs
-typeVariablesInOrderOfAppearance (RefTy innerTy lifetimeTy) =
-  typeVariablesInOrderOfAppearance innerTy ++ typeVariablesInOrderOfAppearance lifetimeTy
-typeVariablesInOrderOfAppearance (PointerTy innerTy) =
-  typeVariablesInOrderOfAppearance innerTy
-typeVariablesInOrderOfAppearance t@(VarTy _) =
-  [t]
-typeVariablesInOrderOfAppearance _ =
-  []

src/Map.hs

@@ -43,3 +43,6 @@ map f (Map m) = Map $ M.map f m
 
 union :: Ord k => Map k v -> Map k v -> Map k v
 union (Map m) (Map m') = (Map (M.union m m'))
+
+assocs :: Map k a -> [(k, a)]
+assocs (Map m) = M.assocs m

src/RenderDocs.hs

@@ -2,7 +2,6 @@
 
 module RenderDocs where
 
-import AssignTypes (typeVariablesInOrderOfAppearance)
 import CMark
 import Control.Monad (when)
 import qualified Data.List as List
@@ -17,6 +16,7 @@ import Text.Blaze.Html.Renderer.Pretty (renderHtml)
 import Text.Blaze.Html5 ((!))
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
+import TypeError (typeVariablesInOrderOfAppearance)
 import Types
 
 -- TODO: Move the beautification to a much earlier place, preferably when the function is defined/concretized-

src/TypeError.hs

@@ -1,6 +1,7 @@
 module TypeError where
 
 import Constraints
+import Data.List (nub)
 import Data.Maybe (fromMaybe)
 import Info
 import qualified Map
@@ -135,29 +136,10 @@ instance Show TypeError where
       ++ prettyInfoFromXObj xobj
       ++ ".\n\nI need exactly one body form. For multiple forms, try using `do`."
   show (UnificationFailed (Constraint a b aObj bObj ctx _) mappings _) =
-    "I can’t match the types `" ++ show (recursiveLookupTy mappings a)
-      ++ "` and `"
-      ++ show (recursiveLookupTy mappings b)
-      ++ "`"
+    "I can’t match the types `" ++ showTy a ++ "` and `" ++ showTy b ++ "`."
       ++ extra
-      ++ ".\n\n"
-      ++
-      --show aObj ++ "\nWITH\n" ++ show bObj ++ "\n\n" ++
-      "  "
-      ++ pretty aObj
-      ++ " : "
-      ++ showTypeFromXObj mappings aObj
-      ++ "\n  At "
-      ++ prettyInfoFromXObj aObj
-      ++ ""
-      ++ "\n\n"
-      ++ "  "
-      ++ pretty bObj
-      ++ " : "
-      ++ showTypeFromXObj mappings bObj
-      ++ "\n  At "
-      ++ prettyInfoFromXObj bObj
-      ++ "\n"
+      ++ showObj aObj
+      ++ showObj bObj
     where
       -- ++ "Constraint: " ++ show constraint ++ "\n\n"
       -- "All constraints:\n" ++ show constraints ++ "\n\n" ++
@@ -167,6 +149,14 @@ instance Show TypeError where
         if length s > 25
           then take 15 s ++ " ... " ++ drop (length s - 5) s
           else s
+      beautifulTy = beautifyTy mappings . recursiveLookupTy mappings
+      showTy = show . beautifulTy
+      showObjTy = fromMaybe "Type missing" . fmap showTy . xobjTy
+      showObj o =
+        "\n\n  " ++ pretty o ++ " : " ++ showObjTy o
+          ++ "\n  At "
+          ++ prettyInfoFromXObj o
+          ++ ""
   show (CantDisambiguate xobj originalName theType options) =
     "I found an ambiguous symbol `" ++ originalName ++ "` of type `"
       ++ show theType
@@ -460,7 +450,7 @@ evalError :: Context -> String -> Maybe Info -> (Context, Either EvalError a)
 evalError ctx = makeEvalError ctx Nothing
 
 -- | Print type errors correctly when running the compiler in 'Check' mode
-makeEvalError :: Context -> Maybe TypeError.TypeError -> String -> Maybe Info -> (Context, Either EvalError a)
+makeEvalError :: Context -> Maybe TypeError -> String -> Maybe Info -> (Context, Either EvalError a)
 makeEvalError ctx err msg info =
   let fppl = projectFilePathPrintLength (contextProj ctx)
       history = contextHistory ctx
@@ -489,3 +479,39 @@ keysInEnvEditDistance path@(SymPath (p : ps) name) env distance =
       case envParent env of
         Just parent -> keysInEnvEditDistance path parent distance
         Nothing -> []
+
+beautifyTy :: TypeMappings -> Ty -> Ty
+beautifyTy mappings = f
+  where
+    f :: Ty -> Ty
+    f (FuncTy argTys retTy lifetime) = FuncTy (f <$> argTys) (f retTy) (f lifetime)
+    f (StructTy n typeArgs) = StructTy n (f <$> typeArgs)
+    f (RefTy innerTy lifetime) = RefTy (f innerTy) (f lifetime)
+    f (PointerTy innerTy) = PointerTy $ f innerTy
+    f t@(VarTy n) = case Map.lookup n bmappings of
+      Just nn -> VarTy nn
+      Nothing -> t
+    f t = t
+    bmappings = beautification mappings
+    beautification :: TypeMappings -> Map.Map String String
+    beautification m =
+      Map.fromList $ zip (map (\(VarTy name) -> name) tys) ((: []) <$> ['a' ..])
+      where
+        tys = nub $ concat $ typeVariablesInOrderOfAppearance <$> tys'
+        tys' = snd <$> Map.assocs m
+
+typeVariablesInOrderOfAppearance :: Ty -> [Ty]
+typeVariablesInOrderOfAppearance (FuncTy argTys retTy ltTy) =
+  concatMap typeVariablesInOrderOfAppearance argTys ++ typeVariablesInOrderOfAppearance retTy ++ typeVariablesInOrderOfAppearance ltTy
+typeVariablesInOrderOfAppearance (StructTy n typeArgs) =
+  case n of
+    t@(VarTy _) -> typeVariablesInOrderOfAppearance t ++ concatMap typeVariablesInOrderOfAppearance typeArgs
+    _ -> concatMap typeVariablesInOrderOfAppearance typeArgs
+typeVariablesInOrderOfAppearance (RefTy innerTy lifetimeTy) =
+  typeVariablesInOrderOfAppearance innerTy ++ typeVariablesInOrderOfAppearance lifetimeTy
+typeVariablesInOrderOfAppearance (PointerTy innerTy) =
+  typeVariablesInOrderOfAppearance innerTy
+typeVariablesInOrderOfAppearance t@(VarTy _) =
+  [t]
+typeVariablesInOrderOfAppearance _ =
+  []