Merge pull request #2132 from purescript/2070

Fix #2070, typed hole errors now include environment information

src/Language/PureScript/Errors.hs

@@ -24,6 +24,7 @@ import Language.PureScript.Crash
 import Language.PureScript.Kinds
 import Language.PureScript.Names
 import Language.PureScript.Pretty
+import Language.PureScript.Traversals
 import Language.PureScript.Types
 import qualified Language.PureScript.Bundle as Bundle
 import qualified Language.PureScript.Constants as C
@@ -112,7 +113,7 @@ data SimpleErrorMessage
   | ShadowedTypeVar String
   | UnusedTypeVar String
   | WildcardInferredType Type
-  | HoleInferredType String Type
+  | HoleInferredType String Type [(Ident, Type)]
   | MissingTypeDeclaration Ident Type
   | OverlappingPattern [[Binder]] Bool
   | IncompleteExhaustivityCheck
@@ -337,14 +338,17 @@ addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint
 
 -- | A map from rigid type variable name/unknown variable pairs to new variables.
 data TypeMap = TypeMap
-  { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan)
-  , umNextSkolem :: Int
-  , umUnknownMap :: M.Map Int Int
-  , umNextUnknown :: Int
+  { umSkolemMap   :: M.Map Int (String, Int, Maybe SourceSpan)
+  -- ^ a map from skolems to their new names, including source and naming info
+  , umUnknownMap  :: M.Map Int Int
+  -- ^ a map from unification variables to their new names
+  , umNextIndex   :: Int
+  -- ^ unknowns and skolems share a source of names during renaming, to
+  -- avoid overlaps in error messages. This is the next label for either case.
   } deriving Show
 
 defaultUnknownMap :: TypeMap
-defaultUnknownMap = TypeMap M.empty 0 M.empty 0
+defaultUnknownMap = TypeMap M.empty M.empty 0
 
 -- | How critical the issue is
 data Level = Error | Warning deriving Show
@@ -363,16 +367,16 @@ replaceUnknowns = everywhereOnTypesM replaceTypes
     m <- get
     case M.lookup u (umUnknownMap m) of
       Nothing -> do
-        let u' = umNextUnknown m
-        put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextUnknown = u' + 1 }
+        let u' = umNextIndex m
+        put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextIndex = u' + 1 }
         return (TUnknown u')
       Just u' -> return (TUnknown u')
   replaceTypes (Skolem name s sko ss) = do
     m <- get
     case M.lookup s (umSkolemMap m) of
       Nothing -> do
-        let s' = umNextSkolem m
-        put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextSkolem = s' + 1 }
+        let s' = umNextIndex m
+        put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 }
         return (Skolem name s' sko ss)
       Just (_, s', _) -> return (Skolem name s' sko ss)
   replaceTypes other = return other
@@ -393,7 +397,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
   gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
   gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
   gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty
-  gSimple (HoleInferredType name ty) = HoleInferredType name <$> f ty
+  gSimple (HoleInferredType name ty env) = HoleInferredType name <$> f ty <*> traverse (sndM f) env
   gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty
   gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty
 
@@ -491,7 +495,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
           : foldMap (return . line . ("  bound at " ++) . displayStartEndPos) ss
 
       unknownInfo :: Int -> Box.Box
-      unknownInfo u = line $ "_" ++ show u ++ " is an unknown type"
+      unknownInfo u = line $ "t" ++ show u ++ " is an unknown type"
 
     renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
     renderSimpleErrorMessage (CannotGetFileInfo path) =
@@ -814,10 +818,20 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
       paras [ line "Wildcard type definition has the inferred type "
             , indent $ typeAsBox ty
             ]
-    renderSimpleErrorMessage (HoleInferredType name ty) =
-      paras [ line $ "Hole '" ++ name ++ "' has the inferred type "
-            , indent $ typeAsBox ty
-            ]
+    renderSimpleErrorMessage (HoleInferredType name ty env) =
+      paras $ [ line $ "Hole '" ++ name ++ "' has the inferred type "
+              , indent $ typeAsBox ty
+              ] ++ if null env then [] else envInfo
+      where
+        envInfo :: [Box.Box]
+        envInfo = [ line "in the following context:"
+                  , indent $ paras
+                      [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")
+                                          , typeAsBox ty'
+                                          ]
+                      | (ident, ty') <- take 5 env
+                      ]
+                  ]
     renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =
       paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."
             , line "It is good practice to provide type declarations as a form of documentation."

src/Language/PureScript/Pretty/Types.hs

@@ -34,7 +34,7 @@ typeLiterals = mkPattern match
   match (TypeVar var) = Just $ text var
   match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
   match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor
-  match (TUnknown u) = Just $ text $ '_' : show u
+  match (TUnknown u) = Just $ text $ 't' : show u
   match (Skolem name s _ _) = Just $ text $ name ++ show s
   match REmpty = Just $ text "()"
   match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

src/Language/PureScript/TypeChecker/Types.hs

@@ -26,6 +26,7 @@ module Language.PureScript.TypeChecker.Types
 
 import Prelude.Compat
 
+import Control.Arrow (second)
 import Control.Monad
 import Control.Monad.Error.Class (MonadError(..))
 import Control.Monad.State.Class (MonadState(..), gets)
@@ -118,8 +119,9 @@ typesOf bindingGroupType moduleName vals = do
   -- Replace all the wildcards types with their inferred types
   replace sub (ErrorMessage hints (WildcardInferredType ty)) =
     ErrorMessage hints . WildcardInferredType $ substituteType sub ty
-  replace sub (ErrorMessage hints (HoleInferredType name ty)) =
-    ErrorMessage hints . HoleInferredType name $ substituteType sub ty
+  replace sub (ErrorMessage hints (HoleInferredType name ty env)) =
+    ErrorMessage hints $ HoleInferredType name (substituteType sub ty)
+                                               (map (second (substituteType sub)) env)
   replace _ em = em
 
   isHoleError :: ErrorMessage -> Bool
@@ -324,7 +326,10 @@ infer' (TypedValue checkType val ty) = do
   return $ TypedValue True val' ty'
 infer' (Hole name) = do
   ty <- freshType
-  tell . errorMessage $ HoleInferredType name ty
+  env <- M.toList . names <$> getEnv
+  Just moduleName <- checkCurrentModule <$> get
+  let ctx = [ (ident, ty') | ((mn, ident@Ident{}), (ty', _, Defined)) <- env, mn == moduleName ]
+  tell . errorMessage $ HoleInferredType name ty ctx
   return $ TypedValue True (Hole name) ty
 infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do
   TypedValue t v ty <- infer' val