b1dfaf1 · rowtype-yoga/purescript-native

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

on golang help sign in

Display hints after main error, resolve #1563

b1dfaf1Phil Freeman11 years ago

src/Language/PureScript/Errors.hs+116−86

compare with golang

unifiedsplit

@@ -56,8 +56,7 @@ import Text.Parsec.Error (Message(..))

57-- | A type of error messages

58data SimpleErrorMessage

59− = ErrorParsingExterns P.ParseError

60− | ErrorParsingFFIModule FilePath

59+ = ErrorParsingFFIModule FilePath

61 | ErrorParsingModule P.ParseError

60 | ErrorParsingModule P.ParseError

62 | MissingFFIModule ModuleName

61 | MissingFFIModule ModuleName

63 | MultipleFFIModules ModuleName [FilePath]

62 | MultipleFFIModules ModuleName [FilePath]

@@ -148,8 +147,7 @@ data SimpleErrorMessage

148

147

149-- | Error message hints, providing more detailed information about failure.

148-- | Error message hints, providing more detailed information about failure.

150data ErrorMessageHint

149data ErrorMessageHint

151− = NotYetDefined [Ident]

152− | ErrorUnifyingTypes Type Type

150+ = ErrorUnifyingTypes Type Type

153 | ErrorInExpression Expr

151 | ErrorInExpression Expr

154 | ErrorInModule ModuleName

152 | ErrorInModule ModuleName

155 | ErrorInInstance (Qualified ProperName) [Type]

153 | ErrorInInstance (Qualified ProperName) [Type]

@@ -192,7 +190,6 @@ instance UnificationError Kind ErrorMessage where

192--

190--

193errorCode :: ErrorMessage -> String

191errorCode :: ErrorMessage -> String

194errorCode em = case unwrapErrorMessage em of

192errorCode em = case unwrapErrorMessage em of

195− ErrorParsingExterns{} -> "ErrorParsingExterns"

196 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"

193 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"

197 ErrorParsingModule{} -> "ErrorParsingModule"

194 ErrorParsingModule{} -> "ErrorParsingModule"

198 MissingFFIModule{} -> "MissingFFIModule"

195 MissingFFIModule{} -> "MissingFFIModule"

@@ -375,9 +372,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

375 prettyPrintErrorMessage :: ErrorMessage -> Box.Box

372 prettyPrintErrorMessage :: ErrorMessage -> Box.Box

376 prettyPrintErrorMessage (ErrorMessage hints simple) =

373 prettyPrintErrorMessage (ErrorMessage hints simple) =

377 paras $

374 paras $

378− map renderHint hints ++

379− [ renderSimpleErrorMessage simple

375+ [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints

376+ , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "

380− , line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."

377+ , line $ "or to contribute content related to this " ++ levelText ++ "."

378+ ]

381 ]

379 ]

382 where

380 where

383 wikiUri :: String

381 wikiUri :: String

@@ -396,10 +394,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

396 paras [ line "Unable to write file: "

394 paras [ line "Unable to write file: "

397 , indent . line $ path

395 , indent . line $ path

398 ]

396 ]

399− renderSimpleErrorMessage (ErrorParsingExterns err) =

400− paras [ lineWithLevel "parsing externs files: "

401− , prettyPrintParseError err

402− ]

403 renderSimpleErrorMessage (ErrorParsingFFIModule path) =

397 renderSimpleErrorMessage (ErrorParsingFFIModule path) =

404 paras [ line "Unable to parse foreign module:"

398 paras [ line "Unable to parse foreign module:"

405 , indent . line $ path

399 , indent . line $ path

@@ -694,81 +688,117 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

694 , line "You may want to decompose your data types into smaller types."

688 , line "You may want to decompose your data types into smaller types."

695 ]

689 ]

696

690

697− renderHint :: ErrorMessageHint -> Box.Box

691+ renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

698− renderHint (NotYetDefined names) =

699− line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

700− renderHint (ErrorUnifyingTypes t1 t2) =

692+ renderHint (ErrorUnifyingTypes t1 t2) detail =

693+ paras [ detail

701− paras [ lineWithLevel "while trying to match type "

694+ , Box.hsep 1 Box.top [ line "while trying to match type"

702− , indent $ typeAsBox t1

695+ , typeAsBox t1

696+ ]

703− , line "with type"

697+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type"

704− , indent $ typeAsBox t2

698+ , typeAsBox t2

699+ ]

705− ]

700+ ]

706− renderHint (ErrorInExpression expr) =

701+ renderHint (ErrorInExpression expr) detail =

707− paras [ lineWithLevel "in expression:"

702+ paras [ detail

703+ , Box.hsep 1 Box.top [ Box.text "in the expression"

708− , indent $ prettyPrintValue expr

704+ , prettyPrintValue expr

705+ ]

709− ]

706+ ]

710− renderHint (ErrorInModule mn) =

707+ renderHint (ErrorInModule mn) detail =

711− paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"

708+ paras [ line $ "in module " ++ runModuleName mn

709+ , detail

712− ]

710+ ]

713− renderHint (ErrorInSubsumption t1 t2) =

711+ renderHint (ErrorInSubsumption t1 t2) detail =

712+ paras [ detail

714− paras [ lineWithLevel "checking that type"

713+ , Box.hsep 1 Box.top [ line "while checking that type"

715− , indent $ typeAsBox t1

714+ , typeAsBox t1

715+ ]

716− , line "is at least as general as type"

716+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type"

717− , indent $ typeAsBox t2

717+ , typeAsBox t2

718+ ]

718− ]

719+ ]

719− renderHint (ErrorInInstance nm ts) =

720+ renderHint (ErrorInInstance nm ts) detail =

721+ paras [ detail

720− paras [ lineWithLevel "in type class instance"

722+ , Box.hsep 1 Box.top [ line "in type class instance"

721− , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

723+ , line (showQualified runProperName nm)

722− , Box.vcat Box.left (map typeAtomAsBox ts)

724+ , Box.vcat Box.left (map typeAtomAsBox ts)

723− ]

725+ ]

724− ]

726+ ]

725− renderHint (ErrorCheckingKind ty) =

727+ renderHint (ErrorCheckingKind ty) detail =

726− paras [ lineWithLevel "checking kind of type"

728+ paras [ detail

729+ , Box.hsep 1 Box.top [ line "while checking the kind of"

727− , indent $ typeAsBox ty

730+ , typeAsBox ty

731+ ]

728− ]

732+ ]

729− renderHint (ErrorInferringType expr) =

733+ renderHint (ErrorInferringType expr) detail =

730− paras [ lineWithLevel "inferring type of expression"

734+ paras [ detail

735+ , Box.hsep 1 Box.top [ line "while inferring the type of"

731− , indent $ prettyPrintValue expr

736+ , prettyPrintValue expr

737+ ]

732− ]

738+ ]

733− renderHint (ErrorCheckingType expr ty) =

739+ renderHint (ErrorCheckingType expr ty) detail =

740+ paras [ detail

734− paras [ lineWithLevel "checking that expression"

741+ , Box.hsep 1 Box.top [ line "while checking that expression"

735− , indent $ prettyPrintValue expr

742+ , prettyPrintValue expr

743+ ]

736− , line "has type"

744+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type"

745+ , typeAsBox ty

746+ ]

747+ ]

748+ renderHint (ErrorCheckingAccessor expr prop) detail =

749+ paras [ detail

750+ , Box.hsep 1 Box.top [ line "while checking type of property accessor"

751+ , prettyPrintValue (Accessor prop expr)

752+ ]

753+ ]

754+ renderHint (ErrorInApplication f t a) detail =

755+ paras [ detail

756+ , Box.hsep 1 Box.top [ line "while applying a function"

757+ , prettyPrintValue f

758+ ]

759+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type"

737− , indent $ typeAsBox ty

760+ , typeAsBox t

761+ ]

762+ , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument"

763+ , prettyPrintValue a

764+ ]

765+ ]

766+ renderHint (ErrorInDataConstructor nm) detail =

767+ paras [ detail

768+ , line $ "in data constructor " ++ runProperName nm

769+ ]

770+ renderHint (ErrorInTypeConstructor nm) detail =

771+ paras [ detail

772+ , line $ "in type constructor " ++ runProperName nm

773+ ]

774+ renderHint (ErrorInBindingGroup nms) detail =

775+ paras [ detail

776+ , line $ "in binding group " ++ intercalate ", " (map showIdent nms)

777+ ]

778+ renderHint ErrorInDataBindingGroup detail =

779+ paras [ detail

780+ , line "in data binding group"

781+ ]

782+ renderHint (ErrorInTypeSynonym name) detail =

783+ paras [ detail

784+ , line $ "in type synonym " ++ runProperName name

785+ ]

786+ renderHint (ErrorInValueDeclaration n) detail =

787+ paras [ detail

788+ , line $ "in value declaration " ++ showIdent n

789+ ]

790+ renderHint (ErrorInTypeDeclaration n) detail =

791+ paras [ detail

792+ , line $ "in type declaration for " ++ showIdent n

793+ ]

794+ renderHint (ErrorInForeignImport nm) detail =

795+ paras [ detail

796+ , line $ "in foreign import " ++ showIdent nm

797+ ]

798+ renderHint (PositionedError srcSpan) detail =

799+ paras [ line $ "at " ++ displaySourceSpan srcSpan

800+ , detail

738 ]

801 ]

739− renderHint (ErrorCheckingAccessor expr prop) =

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

741− , indent $ prettyPrintValue (Accessor prop expr)

742− ]

743− renderHint (ErrorInApplication f t a) =

744− paras [ lineWithLevel "applying a function"

745− , indent $ prettyPrintValue f

746− , line "of type"

747− , indent $ typeAsBox t

748− , line "to argument"

749− , indent $ prettyPrintValue a

750− ]

751− renderHint (ErrorInDataConstructor nm) =

752− lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"

753− renderHint (ErrorInTypeConstructor nm) =

754− lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"

755− renderHint (ErrorInBindingGroup nms) =

756− lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"

757− renderHint ErrorInDataBindingGroup =

758− lineWithLevel "in data binding group:"

759− renderHint (ErrorInTypeSynonym name) =

760− lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"

761− renderHint (ErrorInValueDeclaration n) =

762− lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"

763− renderHint (ErrorInTypeDeclaration n) =

764− lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"

765− renderHint (ErrorInForeignImport nm) =

766− lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"

767− renderHint (PositionedError srcSpan) =

768− lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"

769−

770− lineWithLevel :: String -> Box.Box

771− lineWithLevel text = line $ show level ++ " " ++ text

772

802

773 levelText :: String

803 levelText :: String

774 levelText = case level of

804 levelText = case level of

src/Language/PureScript/Sugar/BindingGroups.hs+12−11

@@ -16,6 +16,7 @@

17{-# LANGUAGE FlexibleContexts #-}

18{-# LANGUAGE CPP #-}

19+{-# LANGUAGE ScopedTypeVariables #-}

20module Language.PureScript.Sugar.BindingGroups (

21module Language.PureScript.Sugar.BindingGroups (

21 createBindingGroups,

22 createBindingGroups,

@@ -28,6 +29,7 @@ import Data.Graph

28import Data.List (nub, intersect)

29import Data.List (nub, intersect)

29import Data.Maybe (isJust, mapMaybe)

30import Data.Maybe (isJust, mapMaybe)

30#if __GLASGOW_HASKELL__ < 710

31#if __GLASGOW_HASKELL__ < 710

32+import Data.Foldable (foldMap)

31import Control.Applicative

33import Control.Applicative

32#endif

34#endif

33import Control.Monad ((<=<))

35import Control.Monad ((<=<))

@@ -54,20 +56,20 @@ createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss c

54collapseBindingGroupsModule :: [Module] -> [Module]

56collapseBindingGroupsModule :: [Module] -> [Module]

55collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps

57collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps

57−createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]

59+createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]

58createBindingGroups moduleName = mapM f <=< handleDecls

60createBindingGroups moduleName = mapM f <=< handleDecls

60 where

62 where

61 (f, _, _) = everywhereOnValuesTopDownM return handleExprs return

63 (f, _, _) = everywhereOnValuesTopDownM return handleExprs return

63− handleExprs :: (Functor m, MonadError MultipleErrors m) => Expr -> m Expr

65+ handleExprs :: Expr -> m Expr

64 handleExprs (Let ds val) = flip Let val <$> handleDecls ds

66 handleExprs (Let ds val) = flip Let val <$> handleDecls ds

65 handleExprs other = return other

67 handleExprs other = return other

67 -- |

69 -- |

68 -- Replace all sets of mutually-recursive declarations with binding groups

70 -- Replace all sets of mutually-recursive declarations with binding groups

69 --

71 --

70− handleDecls :: (Functor m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

72+ handleDecls :: [Declaration] -> m [Declaration]

71 handleDecls ds = do

73 handleDecls ds = do

72 let values = filter isValueDecl ds

74 let values = filter isValueDecl ds

73 dataDecls = filter isDataDecl ds

75 dataDecls = filter isDataDecl ds

@@ -158,7 +160,7 @@ getProperName _ = internalError "Expected DataDeclaration"

158-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

160-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

159--

161--

160--

162--

161−toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration

163+toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration

162toBindingGroup _ (AcyclicSCC d) = return d

164toBindingGroup _ (AcyclicSCC d) = return d

163toBindingGroup moduleName (CyclicSCC ds') =

165toBindingGroup moduleName (CyclicSCC ds') =

164 -- Once we have a mutually-recursive group of declarations, we need to sort

166 -- Once we have a mutually-recursive group of declarations, we need to sort

@@ -178,15 +180,14 @@ toBindingGroup moduleName (CyclicSCC ds') =

178 valueVerts :: [(Declaration, Ident, [Ident])]

180 valueVerts :: [(Declaration, Ident, [Ident])]

179 valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

181 valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

180

182

181− toBinding :: (MonadError MultipleErrors m) => SCC Declaration -> m (Ident, NameKind, Expr)

183+ toBinding :: SCC Declaration -> m (Ident, NameKind, Expr)

182 toBinding (AcyclicSCC d) = return $ fromValueDecl d

184 toBinding (AcyclicSCC d) = return $ fromValueDecl d

183− toBinding (CyclicSCC ~(d:ds)) = cycleError d ds

185+ toBinding (CyclicSCC ds) = throwError $ foldMap cycleError ds

184

186

185− cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a

187+ cycleError :: Declaration -> MultipleErrors

186− cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

188+ cycleError (PositionedDeclaration p _ d) = onErrorMessages (withPosition p) $ cycleError d

187− cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n

189+ cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n

188− cycleError d ds@(_:_) = rethrow (addHint (NotYetDefined (map getIdent ds))) $ cycleError d []

189− cycleError _ _ = internalError "Expected ValueDeclaration"

190+ cycleError _ = internalError "cycleError: Expected ValueDeclaration"

190

191

191toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

192toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

192toDataBindingGroup (AcyclicSCC d) = return d

193toDataBindingGroup (AcyclicSCC d) = return d