2709304 · rowtype-yoga/purescript-native

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

on golang help sign in

Remove erroneous MonadPlus instance after move to ExceptT.

2709304Phil Freeman12 years ago

src/Language/PureScript/Errors.hs+17−10

compare with golang

unifiedsplit

@@ -68,12 +68,6 @@ data ErrorStack

68 = ErrorStack { runErrorStack :: [CompileError] }

69 | MultipleErrors [ErrorStack] deriving (Show)

71−instance Monoid ErrorStack where

72− mempty = ErrorStack []

73− mappend (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)

74− mappend (MultipleErrors es) x = MultipleErrors [ e <> x | e <- es ]

75− mappend x (MultipleErrors es) = MultipleErrors [ x <> e | e <- es ]

76−

77-- TODO: Remove strMsg, the IsString instance, and unnecessary

71-- TODO: Remove strMsg, the IsString instance, and unnecessary

78-- OverloadedStrings pragmas. See #745

72-- OverloadedStrings pragmas. See #745

79-- | Create an ErrorStack from a string

73-- | Create an ErrorStack from a string

@@ -113,10 +107,13 @@ showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " +

113showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg

107showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg

114

108

115mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack

109mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack

116−mkErrorStack msg t = ErrorStack [CompileError msg t Nothing]

110+mkErrorStack msg t = ErrorStack [mkCompileError msg t]

111+

112+mkCompileError :: String -> Maybe ErrorSource -> CompileError

113+mkCompileError msg t = CompileError msg t Nothing

117

114

118−positionError :: SourceSpan -> ErrorStack

115+positionError :: SourceSpan -> CompileError

119−positionError pos = ErrorStack [CompileError "" Nothing (Just pos)]

116+positionError pos = CompileError "" Nothing (Just pos)

120

117

121-- |

118-- |

122-- Rethrow an error with a more detailed error message in the case of failure

119-- Rethrow an error with a more detailed error message in the case of failure

@@ -128,7 +125,7 @@ rethrow f = flip catchError $ \e -> throwError (f e)

128-- Rethrow an error with source position information

125-- Rethrow an error with source position information

129--

126--

130rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a

127rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a

131−rethrowWithPosition pos = rethrow (positionError pos <>)

128+rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)

132

129

133-- |

130-- |

134-- Collect errors in in parallel

131-- Collect errors in in parallel

@@ -144,3 +141,13 @@ parU xs f = forM xs (withError . f) >>= collectErrors

144 [err] -> throwError err

141 [err] -> throwError err

145 [] -> return $ rights es

142 [] -> return $ rights es

146 errs -> throwError $ MultipleErrors errs

143 errs -> throwError $ MultipleErrors errs

144+

145+-- |

146+-- Add an extra error string onto the top of each error stack in a list of possibly many errors

147+--

148+combineErrors :: CompileError -> ErrorStack -> ErrorStack

149+combineErrors ce err = go (ErrorStack [ce]) err

150+ where

151+ go (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)

152+ go (MultipleErrors es) x = MultipleErrors [ go e x | e <- es ]

153+ go x (MultipleErrors es) = MultipleErrors [ go x e | e <- es ]

src/Language/PureScript/Sugar/BindingGroups.hs+1−2

@@ -24,7 +24,6 @@ module Language.PureScript.Sugar.BindingGroups (

24import Data.Graph

25import Data.List (nub, intersect)

26import Data.Maybe (isJust, mapMaybe)

27−import Data.Monoid ((<>))

28import Control.Applicative ((<$>), (<*>), pure)

27import Control.Applicative ((<$>), (<*>), pure)

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

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

@@ -181,7 +180,7 @@ toBindingGroup moduleName (CyclicSCC ds') =

181 cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

180 cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

182 cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $

181 cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $

183 mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))

182 mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))

184− cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []

183+ cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []

185 cycleError _ _ = error "Expected ValueDeclaration"

184 cycleError _ _ = error "Expected ValueDeclaration"

186

185

187toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

186toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

src/Language/PureScript/Sugar/CaseDeclarations.hs+1−2

@@ -19,7 +19,6 @@ module Language.PureScript.Sugar.CaseDeclarations (

19 desugarCasesModule

20) where

22−import Data.Monoid ((<>))

23import Data.List (nub, groupBy)

22import Data.List (nub, groupBy)

25import Control.Applicative

24import Control.Applicative

@@ -44,7 +43,7 @@ isLeft (Right _) = False

44--

43--

45desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]

44desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]

46desugarCasesModule ms = forM ms $ \(Module name ds exps) ->

45desugarCasesModule ms = forM ms $ \(Module name ds exps) ->

47− rethrow (strMsg ("Error in module " ++ show name) <>) $

46+ rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $

48 Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

47 Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

50desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

49desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

src/Language/PureScript/Sugar/Names.hs+5−5

@@ -18,7 +18,6 @@ module Language.PureScript.Sugar.Names (

19import Data.List (nub)

20import Data.Maybe (fromMaybe, isJust, mapMaybe)

21−import Data.Monoid ((<>))

23import Control.Applicative (Applicative(..), (<$>), (<*>))

22import Control.Applicative (Applicative(..), (<$>), (<*>))

24import Control.Monad.Except

23import Control.Monad.Except

@@ -166,7 +165,7 @@ desugarImports modules = do

166 -- the module has access to an unfiltered list of its own members.

165 -- the module has access to an unfiltered list of its own members.

167 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module

166 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module

168 renameInModule' unfilteredExports exports m@(Module mn _ _) =

167 renameInModule' unfilteredExports exports m@(Module mn _ _) =

169− rethrow (strMsg ("Error in module " ++ show mn) <>) $ do

168+ rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ do

170 let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

169 let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

171 let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports

170 let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports

172 imports <- resolveImports env m

171 imports <- resolveImports env m

@@ -233,7 +232,8 @@ renameInModule imports exports (Module mn decls exps) =

233 updateValue (pos, bound) (Let ds val') = do

232 updateValue (pos, bound) (Let ds val') = do

234 let args = mapMaybe letBoundVariable ds

233 let args = mapMaybe letBoundVariable ds

235 unless (length (nub args) == length args) $

234 unless (length (nub args) == length args) $

235+ maybe id rethrowWithPosition pos $

236− throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing

236+ throwError $ mkErrorStack ("Overlapping names in let binding.") Nothing

237 return ((pos, args ++ bound), Let ds val')

238 where

239 updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

@@ -318,7 +318,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

318 addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment

319 addModule env (Module mn ds _) = do

320 env' <- addEmptyModule env mn

321− rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds

321+ rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ foldM (addDecl mn) env' ds

322

323 -- Add a declaration from a module to the global export environment

324 addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment

@@ -344,7 +344,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

344filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment

345filterExports mn exps env = do

346 let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)

347− moduleExports' <- rethrow (strMsg ("Error in module " ++ show mn) <>) $ filterModule moduleExports

347+ moduleExports' <- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ filterModule moduleExports

348 return $ M.insert mn moduleExports' env

349 where

350

src/Language/PureScript/Sugar/Operators.hs+1−2

@@ -34,7 +34,6 @@ import Control.Applicative

34import Control.Monad.State

35import Control.Monad.Except

37−import Data.Monoid ((<>))

38import Data.Function (on)

37import Data.Function (on)

39import Data.Functor.Identity

38import Data.Functor.Identity

40import Data.List (groupBy, sortBy)

39import Data.List (groupBy, sortBy)

@@ -90,7 +89,7 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

90 go [] = return ()

89 go [] = return ()

91 go [_] = return ()

90 go [_] = return ()

92 go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =

91 go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =

93− rethrow (strMsg ("Error in module " ++ show mn) <>) $

92+ rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $

94 rethrowWithPosition pos $

93 rethrowWithPosition pos $

95 throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing

94 throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing

96 go (_ : rest) = go rest

95 go (_ : rest) = go rest

src/Language/PureScript/Sugar/TypeClasses.hs+1−2

@@ -38,7 +38,6 @@ import Control.Monad.Except

38import Control.Monad.State

39import Data.List ((\\), find)

40import Data.Maybe (catMaybes, mapMaybe, isJust)

41−import Data.Monoid ((<>))

43import qualified Data.Map as M

42import qualified Data.Map as M

@@ -225,7 +224,7 @@ unit = TypeApp tyObject REmpty

225

224

226typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

225typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

227typeInstanceDictionaryDeclaration name mn deps className tys decls =

226typeInstanceDictionaryDeclaration name mn deps className tys decls =

228− rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do

227+ rethrow (mkCompileError ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") Nothing `combineErrors`) $ do

229 m <- get

228 m <- get

230

229

231 -- Lookup the type arguments and member types for the type class

230 -- Lookup the type arguments and member types for the type class

src/Language/PureScript/Sugar/TypeDeclarations.hs+1−3

@@ -19,8 +19,6 @@ module Language.PureScript.Sugar.TypeDeclarations (

19 desugarTypeDeclarationsModule

20) where

22−import Data.Monoid ((<>))

23−

24import Control.Applicative

22import Control.Applicative

25import Control.Monad (forM)

23import Control.Monad (forM)

26import Control.Monad.Except (throwError)

24import Control.Monad.Except (throwError)

@@ -36,7 +34,7 @@ import Language.PureScript.Traversals

36--

34--

37desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]

35desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]

38desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->

36desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->

39− rethrow (strMsg ("Error in module " ++ show name) <>) $

37+ rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $

40 Module name <$> desugarTypeDeclarations ds <*> pure exps

38 Module name <$> desugarTypeDeclarations ds <*> pure exps

42-- |

40-- |

src/Language/PureScript/TypeChecker.hs+7−8

@@ -27,7 +27,6 @@ import Language.PureScript.TypeChecker.Synonyms as T

28import Data.Maybe

29import Data.List (nub, (\\), find, intercalate)

30−import Data.Monoid ((<>))

31import Data.Foldable (for_)

30import Data.Foldable (for_)

32import qualified Data.Map as M

31import qualified Data.Map as M

@@ -47,7 +46,7 @@ addDataType moduleName dtype name args dctors ctorKind = do

47 env <- getEnv

46 env <- getEnv

48 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

47 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

49 forM_ dctors $ \(dctor, tys) ->

48 forM_ dctors $ \(dctor, tys) ->

50− rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $

49+ rethrow (mkCompileError ("Error in data constructor " ++ show dctor) Nothing `combineErrors`) $

51 addDataConstructor moduleName dtype name (map fst args) dctor tys

50 addDataConstructor moduleName dtype name (map fst args) dctor tys

53addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

52addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

@@ -134,7 +133,7 @@ typeCheckAll mainModuleName moduleName exps = go

134 go :: [Declaration] -> Check [Declaration]

133 go :: [Declaration] -> Check [Declaration]

135 go [] = return []

134 go [] = return []

136 go (DataDeclaration dtype name args dctors : rest) = do

135 go (DataDeclaration dtype name args dctors : rest) = do

137− rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do

136+ rethrow (mkCompileError ("Error in type constructor " ++ show name) Nothing `combineErrors`) $ do

138 when (dtype == Newtype) $ checkNewtype dctors

137 when (dtype == Newtype) $ checkNewtype dctors

139 checkDuplicateTypeArguments $ map fst args

138 checkDuplicateTypeArguments $ map fst args

140 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)

139 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)

@@ -148,7 +147,7 @@ typeCheckAll mainModuleName moduleName exps = go

148 checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"

147 checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"

149 checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"

148 checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"

150 go (d@(DataBindingGroupDeclaration tys) : rest) = do

149 go (d@(DataBindingGroupDeclaration tys) : rest) = do

151− rethrow (strMsg "Error in data binding group" <>) $ do

150+ rethrow (mkCompileError "Error in data binding group" Nothing `combineErrors`) $ do

152 let syns = mapMaybe toTypeSynonym tys

151 let syns = mapMaybe toTypeSynonym tys

153 let dataDecls = mapMaybe toDataDecl tys

152 let dataDecls = mapMaybe toDataDecl tys

154 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

153 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

@@ -170,7 +169,7 @@ typeCheckAll mainModuleName moduleName exps = go

170 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'

169 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'

171 toDataDecl _ = Nothing

170 toDataDecl _ = Nothing

172 go (TypeSynonymDeclaration name args ty : rest) = do

171 go (TypeSynonymDeclaration name args ty : rest) = do

173− rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do

172+ rethrow (mkCompileError ("Error in type synonym " ++ show name) Nothing `combineErrors`) $ do

174 checkDuplicateTypeArguments $ map fst args

173 checkDuplicateTypeArguments $ map fst args

175 kind <- kindsOf False moduleName name args [ty]

174 kind <- kindsOf False moduleName name args [ty]

176 let args' = args `withKinds` kind

175 let args' = args `withKinds` kind

@@ -179,7 +178,7 @@ typeCheckAll mainModuleName moduleName exps = go

179 return $ TypeSynonymDeclaration name args ty : ds

178 return $ TypeSynonymDeclaration name args ty : ds

180 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

179 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

181 go (ValueDeclaration name nameKind [] (Right val) : rest) = do

180 go (ValueDeclaration name nameKind [] (Right val) : rest) = do

182− d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do

181+ d <- rethrow (mkCompileError ("Error in declaration " ++ show name) Nothing `combineErrors`) $ do

183 valueIsNotDefined moduleName name

182 valueIsNotDefined moduleName name

184 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]

183 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]

185 addValue moduleName name ty nameKind

184 addValue moduleName name ty nameKind

@@ -188,7 +187,7 @@ typeCheckAll mainModuleName moduleName exps = go

188 return $ d : ds

187 return $ d : ds

189 go (ValueDeclaration{} : _) = error "Binders were not desugared"

188 go (ValueDeclaration{} : _) = error "Binders were not desugared"

190 go (BindingGroupDeclaration vals : rest) = do

189 go (BindingGroupDeclaration vals : rest) = do

191− d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do

190+ d <- rethrow (mkCompileError ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) Nothing `combineErrors`) $ do

192 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

191 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

193 valueIsNotDefined moduleName name

192 valueIsNotDefined moduleName name

194 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals

193 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals

@@ -208,7 +207,7 @@ typeCheckAll mainModuleName moduleName exps = go

208 ds <- go rest

207 ds <- go rest

209 return $ d : ds

208 return $ d : ds

210 go (d@(ExternDeclaration importTy name _ ty) : rest) = do

209 go (d@(ExternDeclaration importTy name _ ty) : rest) = do

211− rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do

210+ rethrow (mkCompileError ("Error in foreign import declaration " ++ show name) Nothing `combineErrors`) $ do

212 env <- getEnv

211 env <- getEnv

213 kind <- kindOf moduleName ty

212 kind <- kindOf moduleName ty

214 guardWith (strMsg "Expected kind *") $ kind == Star

213 guardWith (strMsg "Expected kind *") $ kind == Star

src/Language/PureScript/TypeChecker/Kinds.hs+2−3

@@ -24,7 +24,6 @@ module Language.PureScript.TypeChecker.Kinds (

24) where

26import Data.Maybe (fromMaybe)

27−import Data.Monoid ((<>))

29import qualified Data.HashMap.Strict as H

28import qualified Data.HashMap.Strict as H

30import qualified Data.Map as M

29import qualified Data.Map as M

@@ -79,7 +78,7 @@ kindOf _ ty = fst <$> kindOfWithScopedVars ty

79--

78--

80kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])

79kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])

81kindOfWithScopedVars ty =

80kindOfWithScopedVars ty =

82− rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $

81+ rethrow (mkCompileError "Error checking kind" (Just (TypeError ty)) `combineErrors`) $

83 fmap tidyUp . liftUnify $ infer ty

82 fmap tidyUp . liftUnify $ infer ty

84 where

83 where

85 tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)

84 tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)

@@ -157,7 +156,7 @@ starIfUnknown k = k

157-- Infer a kind for a type

156-- Infer a kind for a type

158--

157--

159infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

158infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

160−infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty

159+infer ty = rethrow (mkCompileError "Error inferring type of value" (Just (TypeError ty)) `combineErrors`) $ infer' ty

161

160

162infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

161infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

163infer' (ForAll ident ty _) = do

162infer' (ForAll ident ty _) = do

src/Language/PureScript/TypeChecker/Subsumption.hs+1−2

@@ -18,7 +18,6 @@ module Language.PureScript.TypeChecker.Subsumption (

18) where

20import Data.List (sortBy)

21−import Data.Monoid

22import Data.Ord (comparing)

21import Data.Ord (comparing)

24import Control.Applicative

23import Control.Applicative

@@ -39,7 +38,7 @@ import Language.PureScript.Types

39-- Check whether one type subsumes another, rethrowing errors to provide a better error message

38-- Check whether one type subsumes another, rethrowing errors to provide a better error message

40--

39--

41subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)

40subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)

42−subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2

41+subsumes val ty1 ty2 = rethrow (mkCompileError errorMessage (ExprError <$> val) `combineErrors`) $ subsumes' val ty1 ty2

43 where

42 where

44 errorMessage = "Error checking that type "

43 errorMessage = "Error checking that type "

45 ++ prettyPrintType ty1

44 ++ prettyPrintType ty1

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

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

38import Data.Either (lefts, rights)

39import Data.List

40import Data.Maybe (fromMaybe)

41−import Data.Monoid

42import qualified Data.Map as M

41import qualified Data.Map as M

43import Data.String (IsString)

42import Data.String (IsString)

@@ -208,7 +207,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)

208-- Infer a type for a value, rethrowing any error to provide a more useful error message

207-- Infer a type for a value, rethrowing any error to provide a more useful error message

209--

208--

210infer :: Expr -> UnifyT Type Check Expr

209infer :: Expr -> UnifyT Type Check Expr

211−infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ExprError val)) <>) $ infer' val

210+infer val = rethrow (mkCompileError "Error inferring type of value" (Just (ExprError val)) `combineErrors`) $ infer' val

212

211

213-- |

212-- |

214-- Infer a type for a value

213-- Infer a type for a value

@@ -428,7 +427,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do

428-- Check the type of a value, rethrowing errors to provide a better error message

427-- Check the type of a value, rethrowing errors to provide a better error message

429--

428--

430check :: Expr -> Type -> UnifyT Type Check Expr

429check :: Expr -> Type -> UnifyT Type Check Expr

431−check val ty = rethrow (mkErrorStack errorMessage (Just (ExprError val)) <>) $ check' val ty

430+check val ty = rethrow (mkCompileError errorMessage (Just (ExprError val)) `combineErrors`) $ check' val ty

432 where

431 where

433 errorMessage =

432 errorMessage =

434 "Error checking type of term " ++

433 "Error checking type of term " ++

@@ -610,7 +609,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

610-- Check the type of a function application, rethrowing errors to provide a better error message

609-- Check the type of a function application, rethrowing errors to provide a better error message

611--

610--

612checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)

611checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)

613−checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ExprError fn)) <>) $ do

612+checkFunctionApplication fn fnTy arg ret = rethrow (mkCompileError errorMessage (Just (ExprError fn)) `combineErrors`) $ do

614 subst <- unifyCurrentSubstitution <$> UnifyT get

613 subst <- unifyCurrentSubstitution <$> UnifyT get

615 checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)

614 checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)

616 where

615 where

src/Language/PureScript/TypeChecker/Unify.hs+1−2

@@ -27,7 +27,6 @@ module Language.PureScript.TypeChecker.Unify (

28import Data.List (nub, sort)

29import Data.Maybe (fromMaybe)

30−import Data.Monoid

31import qualified Data.HashMap.Strict as H

30import qualified Data.HashMap.Strict as H

33import Control.Monad.Except

32import Control.Monad.Except

@@ -61,7 +60,7 @@ instance Unifiable Check Type where

61-- Unify two types, updating the current substitution

60-- Unify two types, updating the current substitution

62--

61--

63unifyTypes :: Type -> Type -> UnifyT Type Check ()

62unifyTypes :: Type -> Type -> UnifyT Type Check ()

64−unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $

63+unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing `combineErrors`) $

65 unifyTypes' t1 t2

64 unifyTypes' t1 t2

66 where

65 where

67 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

66 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()