35afca6 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1562 from purescript/1557

35afca6Phil Freeman11 years ago

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

compare with golang

unifiedsplit

@@ -20,7 +20,7 @@

20module Language.PureScript.Errors where

22import Data.Either (lefts, rights)

23−import Data.List (intercalate, transpose, nub, nubBy, partition)

23+import Data.List (intercalate, transpose, nub, nubBy)

24import Data.Function (on)

25#if __GLASGOW_HASKELL__ < 710

26import Data.Foldable (fold, foldMap)

@@ -154,6 +154,7 @@ data ErrorMessageHint

154 | ErrorInModule ModuleName

155 | ErrorInInstance (Qualified ProperName) [Type]

156 | ErrorInSubsumption Type Type

157+ | ErrorCheckingAccessor Expr String

157 | ErrorCheckingType Expr Type

158 | ErrorCheckingType Expr Type

158 | ErrorCheckingKind Type

159 | ErrorCheckingKind Type

159 | ErrorInferringType Expr

160 | ErrorInferringType Expr

@@ -367,8 +368,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

367-- Pretty print a single error, simplifying if necessary

368-- Pretty print a single error, simplifying if necessary

368--

369--

369prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box

370prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box

370−prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFirst . reverseHints <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

371+prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

371− where

372+ where

372

373

373 -- Pretty print an ErrorMessage

374 -- Pretty print an ErrorMessage

374 prettyPrintErrorMessage :: ErrorMessage -> Box.Box

375 prettyPrintErrorMessage :: ErrorMessage -> Box.Box

@@ -735,6 +736,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

735 , line "has type"

736 , line "has type"

736 , indent $ typeAsBox ty

737 , indent $ typeAsBox ty

737 ]

738 ]

739+ renderHint (ErrorCheckingAccessor expr prop) =

740+ paras [ lineWithLevel "checking type of property accessor"

741+ , indent $ prettyPrintValue (Accessor prop expr)

742+ ]

738 renderHint (ErrorInApplication f t a) =

743 renderHint (ErrorInApplication f t a) =

739 paras [ lineWithLevel "applying a function"

744 paras [ lineWithLevel "applying a function"

740 , indent $ prettyPrintValue f

745 , indent $ prettyPrintValue f

@@ -782,19 +787,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

782 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name

787 prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name

783 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

788 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

784

789

785− -- Hints get added at the front, so we need to reverse them before rendering

786− reverseHints :: ErrorMessage -> ErrorMessage

787− reverseHints (ErrorMessage hints simple) = ErrorMessage (reverse hints) simple

788−

789− -- | Put positional hints at the front of the list

790− positionHintsFirst :: ErrorMessage -> ErrorMessage

791− positionHintsFirst (ErrorMessage hints simple) = ErrorMessage (uncurry (++) $ partition (isPositionHint . hintCategory) hints) simple

792− where

793− isPositionHint :: HintCategory -> Bool

794− isPositionHint PositionHint = True

795− isPositionHint OtherHint = True

796− isPositionHint _ = False

797−

798 -- | Simplify an error message

790 -- | Simplify an error message

799 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

791 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

800 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple

792 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple

src/Language/PureScript/TypeChecker/Types.hs+2−2

@@ -232,7 +232,7 @@ infer' (ObjectUpdate o ps) = do

232 let oldTy = TypeApp tyObject $ rowFromList (oldTys, row)

233 o' <- TypedValue True <$> check o oldTy <*> pure oldTy

234 return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row)

235−infer' (Accessor prop val) = do

235+infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do

236 field <- fresh

237 rest <- fresh

238 typed <- check val (TypeApp tyObject (RCons prop field rest))

@@ -551,7 +551,7 @@ check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do

551 obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))

552 ps' <- checkProperties ps row True

553 return $ TypedValue True (ObjectUpdate obj' ps') t

554−check' (Accessor prop val) ty = do

554+check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do

555 rest <- fresh

556 val' <- check val (TypeApp tyObject (RCons prop ty rest))

557 return $ TypedValue True (Accessor prop val') ty