ddd8101 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #2132 from purescript/2070

ddd8101Phil Freeman10 years ago

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

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

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

337

338

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

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

339data TypeMap = TypeMap

340data TypeMap = TypeMap

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

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

341− , umNextSkolem :: Int

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

342− , umUnknownMap :: M.Map Int Int

343+ , umUnknownMap :: M.Map Int Int

343− , umNextUnknown :: 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.

344 } deriving Show

348 } deriving Show

345

349

346defaultUnknownMap :: TypeMap

350defaultUnknownMap :: TypeMap

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

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

348

352

349-- | How critical the issue is

353-- | How critical the issue is

350data Level = Error | Warning deriving Show

354data Level = Error | Warning deriving Show

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

363 m <- get

367 m <- get

364 case M.lookup u (umUnknownMap m) of

368 case M.lookup u (umUnknownMap m) of

365 Nothing -> do

369 Nothing -> do

366− let u' = umNextUnknown m

370+ let u' = umNextIndex m

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

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

368 return (TUnknown u')

372 return (TUnknown u')

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

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

370 replaceTypes (Skolem name s sko ss) = do

374 replaceTypes (Skolem name s sko ss) = do

371 m <- get

375 m <- get

372 case M.lookup s (umSkolemMap m) of

376 case M.lookup s (umSkolemMap m) of

373 Nothing -> do

377 Nothing -> do

374− let s' = umNextSkolem m

378+ let s' = umNextIndex m

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

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

376 return (Skolem name s' sko ss)

380 return (Skolem name s' sko ss)

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

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

378 replaceTypes other = return other

382 replaceTypes other = return other

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

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

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

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

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

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

399 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

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

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

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

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

399

403

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

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

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

492

496

493 unknownInfo :: Int -> Box.Box

497 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"

495

499

496 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

500 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

497 renderSimpleErrorMessage (CannotGetFileInfo path) =

501 renderSimpleErrorMessage (CannotGetFileInfo path) =

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

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

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

815 , indent $ typeAsBox ty

819 , indent $ typeAsBox ty

816 ]

820 ]

817− renderSimpleErrorMessage (HoleInferredType name ty) =

821+ renderSimpleErrorMessage (HoleInferredType name ty env) =

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

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

819− , 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+ ]

820− ]

834+ ]

821 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

835 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

822 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 ++ "."

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