Merge pull request purescript#1082 from purescript/errors

paf31 · paf31 · commit 04cd31cfcab2 · 2015-04-26T15:30:50.000-07:00
Errors
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,18 +255,24 @@ errorMessage err = MultipleErrors [err]
 onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
 onErrorMessages f = MultipleErrors . map f . runMultipleErrors
 
-replaceUnknowns :: Type -> State [Unknown] 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)
+-- | The various types of things which might need to be relabelled in errors messages.
+data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord)
 
-    replaceUnknowns' :: Type -> State [Unknown] Type
-    replaceUnknowns' (TUnknown u) = state $ first TUnknown . lookupTable u
-    replaceUnknowns' other = return other
+-- | A map from rigid type variable name/unknown variable pairs to new variables.
+type UnknownMap = M.Map (LabelType, Unknown) Unknown
+
+replaceUnknowns :: Type -> State UnknownMap Type
+replaceUnknowns = everywhereOnTypesM replaceTypes 
+  where
+  lookupTable :: (LabelType, 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)
 
+  replaceTypes :: Type -> State UnknownMap Type
+  replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u)
+  replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s)
+  replaceTypes other = return other
 
 onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
 onTypesInErrorMessageM f = g
@@ -298,7 +307,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 +578,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/Kinds.hs b/src/Language/PureScript/Kinds.hs
@@ -18,6 +18,7 @@ module Language.PureScript.Kinds where
 
 import Data.Data
 
+import Control.Applicative
 import Control.Monad.Unify (Unknown)
 
 -- |
@@ -52,6 +53,13 @@ everywhereOnKinds f = go
   go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
   go other = f other
 
+everywhereOnKindsM :: (Functor m, Applicative m, Monad m) => (Kind -> m Kind) -> Kind -> m Kind
+everywhereOnKindsM f = go
+  where
+  go (Row k1) = (Row <$> go k1) >>= f
+  go (FunKind k1 k2) = (FunKind <$> go k1 <*> go k2) >>= f
+  go other = f other
+
 everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
 everythingOnKinds (<>) f = go
   where
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) ++ ">"
