ddd8101 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Merge pull request #2132 from purescript/2070

Fix #2070, typed hole errors now include environment information

commitddd8101d1bae43a70c7dc548a5c05ca482653bed authorPhil Freeman <paf31@cantab.net> dateSun 22 May 2016, 14:07 (10 years ago) parentcd4c708 8703a73

3 files changed+39−20

compare with golang

unifiedsplit

src/Language/PureScript/Errors.hs+30−16 src/Language/PureScript/Pretty/Types.hs+1−1 src/Language/PureScript/TypeChecker/Types.hs+8−3

src/Language/PureScript/Errors.hs+30−16

@@ -24,6 +24,7 @@ import Language.PureScript.Crash

2424import Language.PureScript.Kinds

2525import Language.PureScript.Names

2626import Language.PureScript.Pretty

27+import Language.PureScript.Traversals

2728import Language.PureScript.Types

2829import qualified Language.PureScript.Bundle as Bundle

2930import qualified Language.PureScript.Constants as C

@@ -112,7 +113,7 @@ data SimpleErrorMessage

112113 | ShadowedTypeVar String

113114 | UnusedTypeVar String

114115 | WildcardInferredType Type

115− | HoleInferredType String Type

116+ | HoleInferredType String Type [(Ident, Type)]

116117 | MissingTypeDeclaration Ident Type

117118 | OverlappingPattern [[Binder]] Bool

118119 | IncompleteExhaustivityCheck

@@ -337,14 +338,17 @@ addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint

337338

338339-- | A map from rigid type variable name/unknown variable pairs to new variables.

339340data TypeMap = TypeMap

340− { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan)

341− , umNextSkolem :: Int

342− , umUnknownMap :: M.Map Int Int

343− , umNextUnknown :: Int

341+ { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan)

342+ -- ^ a map from skolems to their new names, including source and naming info

343+ , umUnknownMap :: M.Map Int Int

344+ -- ^ a map from unification variables to their new names

345+ , umNextIndex :: Int

346+ -- ^ unknowns and skolems share a source of names during renaming, to

347+ -- avoid overlaps in error messages. This is the next label for either case.

344348 } deriving Show

345349

346350defaultUnknownMap :: TypeMap

347−defaultUnknownMap = TypeMap M.empty 0 M.empty 0

351+defaultUnknownMap = TypeMap M.empty M.empty 0

348352

349353-- | How critical the issue is

350354data Level = Error | Warning deriving Show

@@ -363,16 +367,16 @@ replaceUnknowns = everywhereOnTypesM replaceTypes

363367 m <- get

364368 case M.lookup u (umUnknownMap m) of

365369 Nothing -> do

366− let u' = umNextUnknown m

367− put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextUnknown = u' + 1 }

370+ let u' = umNextIndex m

371+ put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextIndex = u' + 1 }

368372 return (TUnknown u')

369373 Just u' -> return (TUnknown u')

370374 replaceTypes (Skolem name s sko ss) = do

371375 m <- get

372376 case M.lookup s (umSkolemMap m) of

373377 Nothing -> do

374− let s' = umNextSkolem m

375− put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextSkolem = s' + 1 }

378+ let s' = umNextIndex m

379+ put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 }

376380 return (Skolem name s' sko ss)

377381 Just (_, s', _) -> return (Skolem name s' sko ss)

378382 replaceTypes other = return other

@@ -393,7 +397,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

393397 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

394398 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

395399 gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty

396− gSimple (HoleInferredType name ty) = HoleInferredType name <$> f ty

400+ gSimple (HoleInferredType name ty env) = HoleInferredType name <$> f ty <*> traverse (sndM f) env

397401 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty

398402 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty

399403

@@ -491,7 +495,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

491495 : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss

492496

493497 unknownInfo :: Int -> Box.Box

494− unknownInfo u = line $ "_" ++ show u ++ " is an unknown type"

498+ unknownInfo u = line $ "t" ++ show u ++ " is an unknown type"

495499

496500 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

497501 renderSimpleErrorMessage (CannotGetFileInfo path) =

@@ -814,10 +818,20 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

814818 paras [ line "Wildcard type definition has the inferred type "

815819 , indent $ typeAsBox ty

816820 ]

817− renderSimpleErrorMessage (HoleInferredType name ty) =

818− paras [ line $ "Hole '" ++ name ++ "' has the inferred type "

819− , indent $ typeAsBox ty

820− ]

821+ renderSimpleErrorMessage (HoleInferredType name ty env) =

822+ paras $ [ line $ "Hole '" ++ name ++ "' has the inferred type "

823+ , indent $ typeAsBox ty

824+ ] ++ if null env then [] else envInfo

825+ where

826+ envInfo :: [Box.Box]

827+ envInfo = [ line "in the following context:"

828+ , indent $ paras

829+ [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")

830+ , typeAsBox ty'

831+ ]

832+ | (ident, ty') <- take 5 env

833+ ]

834+ ]

821835 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

822836 paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."

823837 , line "It is good practice to provide type declarations as a form of documentation."

src/Language/PureScript/Pretty/Types.hs+1−1

@@ -34,7 +34,7 @@ typeLiterals = mkPattern match

3434 match (TypeVar var) = Just $ text var

3535 match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row

3636 match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

37− match (TUnknown u) = Just $ text $ '_' : show u

37+ match (TUnknown u) = Just $ text $ 't' : show u

3838 match (Skolem name s _ _) = Just $ text $ name ++ show s

3939 match REmpty = Just $ text "()"

4040 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

src/Language/PureScript/TypeChecker/Types.hs+8−3

@@ -26,6 +26,7 @@ module Language.PureScript.TypeChecker.Types

2626

2727import Prelude.Compat

2828

29+import Control.Arrow (second)

2930import Control.Monad

3031import Control.Monad.Error.Class (MonadError(..))

3132import Control.Monad.State.Class (MonadState(..), gets)

@@ -118,8 +119,9 @@ typesOf bindingGroupType moduleName vals = do

118119 -- Replace all the wildcards types with their inferred types

119120 replace sub (ErrorMessage hints (WildcardInferredType ty)) =

120121 ErrorMessage hints . WildcardInferredType $ substituteType sub ty

121− replace sub (ErrorMessage hints (HoleInferredType name ty)) =

122− ErrorMessage hints . HoleInferredType name $ substituteType sub ty

122+ replace sub (ErrorMessage hints (HoleInferredType name ty env)) =

123+ ErrorMessage hints $ HoleInferredType name (substituteType sub ty)

124+ (map (second (substituteType sub)) env)

123125 replace _ em = em

124126

125127 isHoleError :: ErrorMessage -> Bool

@@ -324,7 +326,10 @@ infer' (TypedValue checkType val ty) = do

324326 return $ TypedValue True val' ty'

325327infer' (Hole name) = do

326328 ty <- freshType

327− tell . errorMessage $ HoleInferredType name ty

329+ env <- M.toList . names <$> getEnv

330+ Just moduleName <- checkCurrentModule <$> get

331+ let ctx = [ (ident, ty') | ((mn, ident@Ident{}), (ty', _, Defined)) <- env, mn == moduleName ]

332+ tell . errorMessage $ HoleInferredType name ty ctx

328333 return $ TypedValue True (Hole name) ty

329334infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do

330335 TypedValue t v ty <- infer' val