3ca81cc · rowtype-yoga/purescript-native

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

on golang help sign in

Fix #2070, typed hole errors now include environment information

3ca81ccPhil Freeman10 years ago

src/Language/PureScript/Errors.hs+18−7

compare with golang

unifiedsplit

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

24import Language.PureScript.Kinds

25import Language.PureScript.Names

26import Language.PureScript.Pretty

27+import Language.PureScript.Traversals

27import Language.PureScript.Types

28import Language.PureScript.Types

28import qualified Language.PureScript.Bundle as Bundle

29import qualified Language.PureScript.Bundle as Bundle

29import qualified Language.PureScript.Constants as C

30import qualified Language.PureScript.Constants as C

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

112 | ShadowedTypeVar String

113 | ShadowedTypeVar String

113 | UnusedTypeVar String

114 | UnusedTypeVar String

114 | WildcardInferredType Type

115 | WildcardInferredType Type

115− | HoleInferredType String Type

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

116 | MissingTypeDeclaration Ident Type

117 | MissingTypeDeclaration Ident Type

117 | OverlappingPattern [[Binder]] Bool

118 | OverlappingPattern [[Binder]] Bool

118 | IncompleteExhaustivityCheck

119 | IncompleteExhaustivityCheck

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

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

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

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

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

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

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

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

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

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

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

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

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

401

402

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

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

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

495

496

496 unknownInfo :: Int -> Box.Box

497 unknownInfo :: Int -> Box.Box

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

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

498

499

499 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

500 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

500 renderSimpleErrorMessage (CannotGetFileInfo path) =

501 renderSimpleErrorMessage (CannotGetFileInfo path) =

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

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

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

818 , indent $ typeAsBox ty

819 , indent $ typeAsBox ty

819 ]

820 ]

820− renderSimpleErrorMessage (HoleInferredType name ty) =

821+ renderSimpleErrorMessage (HoleInferredType name ty env) =

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

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

822− , indent $ typeAsBox ty

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+ ]

823− ]

834+ ]

824 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

835 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

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

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

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

837 , 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

34 match (TypeVar var) = Just $ text var

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

36 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

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

39 match REmpty = Just $ text "()"

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

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

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

27import Prelude.Compat

29+import Control.Arrow (second)

29import Control.Monad

30import Control.Monad

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

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

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

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

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

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

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

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

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

120 ErrorMessage hints . WildcardInferredType $ substituteType sub ty

121 ErrorMessage hints . WildcardInferredType $ substituteType sub ty

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

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

122− ErrorMessage hints . HoleInferredType name $ substituteType sub ty

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

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

123 replace _ em = em

125 replace _ em = em

124

126

125 isHoleError :: ErrorMessage -> Bool

127 isHoleError :: ErrorMessage -> Bool

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

324 return $ TypedValue True val' ty'

326 return $ TypedValue True val' ty'

325infer' (Hole name) = do

327infer' (Hole name) = do

326 ty <- freshType

328 ty <- freshType

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

330+ Just moduleName <- checkCurrentModule <$> get

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

327− tell . errorMessage $ HoleInferredType name ty

332+ tell . errorMessage $ HoleInferredType name ty ctx

328 return $ TypedValue True (Hole name) ty

333 return $ TypedValue True (Hole name) ty

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

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

330 TypedValue t v ty <- infer' val

335 TypedValue t v ty <- infer' val