Nicer errors for skolemized types

paf31 · paf31 · commit b578d26563d2 · 2015-04-26T13:25:11.000-07:00
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -19,10 +19,13 @@
 module Language.PureScript.Errors where
 
 import Data.Either (lefts, rights)
-import Data.List (intercalate, elemIndex)
+import Data.List (intercalate)
+import Data.Function (on)
 import Data.Monoid
 import Data.Foldable (fold, foldMap)
 
+import qualified Data.Map as M
+
 import Control.Monad
 import Control.Monad.Error.Class (MonadError(..))
 import Control.Monad.Unify
@@ -252,19 +255,22 @@ errorMessage err = MultipleErrors [err]
 onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
 onErrorMessages f = MultipleErrors . map f . runMultipleErrors
 
-replaceUnknowns :: Type -> State [Unknown] Type
+-- | A map from rigid type variable name/unknown variable pairs to new variables.
+type UnknownMap = M.Map (Maybe String, Unknown) Unknown
+
+replaceUnknowns :: Type -> State UnknownMap Type
 replaceUnknowns = everywhereOnTypesM replaceUnknowns'
   where
-    lookupTable :: Unknown -> [Unknown] -> (Unknown, [Unknown])
-    lookupTable x table = case (elemIndex x table) of
-                               Nothing -> (length table, table ++ [x])
-                               Just i  -> (i, table)
-
-    replaceUnknowns' :: Type -> State [Unknown] Type
-    replaceUnknowns' (TUnknown u) = state $ first TUnknown . lookupTable u
+    lookupTable :: (Maybe String, Unknown) -> UnknownMap -> (Unknown, UnknownMap)
+    lookupTable x m = case M.lookup x m of
+                        Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)
+                        Just i  -> (i, m)
+
+    replaceUnknowns' :: Type -> State UnknownMap Type
+    replaceUnknowns' (TUnknown u) = state $ first TUnknown . lookupTable (Nothing, u)
+    replaceUnknowns' (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (Just name, s)
     replaceUnknowns' other = return other
 
-
 onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
 onTypesInErrorMessageM f = g
   where
@@ -298,7 +304,7 @@ onTypesInErrorMessageM f = g
 -- |
 -- Pretty print a single error, simplifying if necessary
 --
-prettyPrintSingleError :: Bool -> ErrorMessage -> State [Unknown] Box.Box
+prettyPrintSingleError :: Bool -> ErrorMessage -> State UnknownMap Box.Box
 prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
  where
   -- |
@@ -569,15 +575,15 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
 -- Pretty print multiple errors
 --
 prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
-prettyPrintMultipleErrors full = flip evalState [] . prettyPrintMultipleErrorsWith "Error:" "Multiple errors:" full
+prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith "Error:" "Multiple errors:" full
 
 -- |
 -- Pretty print multiple warnings
 --
 prettyPrintMultipleWarnings :: Bool -> MultipleErrors ->  String
-prettyPrintMultipleWarnings full = flip evalState [] . prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:" full
+prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:" full
 
-prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> State [Unknown] String
+prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> State UnknownMap String
 prettyPrintMultipleErrorsWith intro _ full  (MultipleErrors [e]) = do
   result <- prettyPrintSingleError full e
   return $ renderBox $
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
@@ -39,7 +39,7 @@ typeLiterals = mkPattern match
   match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
   match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
   match (TypeConstructor ctor) = Just $ show ctor
-  match (TUnknown u) = Just $ 'u' : show u
+  match (TUnknown u) = Just $ '_' : show u
   match (Skolem name s _) = Just $ name ++ show s
   match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
   match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
