Skip to content

Commit 2709304

Browse files
paf31paf31
committed
Remove erroneous MonadPlus instance after move to ExceptT.
1 parent fe55e94 commit 2709304

File tree

12 files changed

+41
-45
lines changed

12 files changed

+41
-45
lines changed

‎src/Language/PureScript/Errors.hs‎

Lines changed: 17 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -68,12 +68,6 @@ data ErrorStack
6868
= ErrorStack { runErrorStack :: [CompileError] }
6969
| MultipleErrors [ErrorStack] deriving (Show)
7070

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-
7771
-- TODO: Remove strMsg, the IsString instance, and unnecessary
7872
-- OverloadedStrings pragmas. See #745
7973
-- | Create an ErrorStack from a string
@@ -113,10 +107,13 @@ showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " +
113107
showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
114108

115109
mkErrorStack :: 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
117114

118-
positionError :: SourceSpan -> ErrorStack
119-
positionError pos = ErrorStack [CompileError "" Nothing (Just pos)]
115+
positionError :: SourceSpan -> CompileError
116+
positionError pos = CompileError "" Nothing (Just pos)
120117

121118
-- |
122119
-- 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)
128125
-- Rethrow an error with source position information
129126
--
130127
rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a
131-
rethrowWithPosition pos = rethrow (positionError pos <>)
128+
rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)
132129

133130
-- |
134131
-- Collect errors in in parallel
@@ -144,3 +141,13 @@ parU xs f = forM xs (withError . f) >>= collectErrors
144141
[err] -> throwError err
145142
[] -> return $ rights es
146143
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‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,6 @@ module Language.PureScript.Sugar.BindingGroups (
2424
import Data.Graph
2525
import Data.List (nub, intersect)
2626
import Data.Maybe (isJust, mapMaybe)
27-
import Data.Monoid ((<>))
2827
import Control.Applicative ((<$>), (<*>), pure)
2928
import Control.Monad ((<=<))
3029

@@ -181,7 +180,7 @@ toBindingGroup moduleName (CyclicSCC ds') =
181180
cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds
182181
cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $
183182
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 []
185184
cycleError _ _ = error "Expected ValueDeclaration"
186185

187186
toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

‎src/Language/PureScript/Sugar/CaseDeclarations.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,6 @@ module Language.PureScript.Sugar.CaseDeclarations (
1919
desugarCasesModule
2020
) where
2121

22-
import Data.Monoid ((<>))
2322
import Data.List (nub, groupBy)
2423

2524
import Control.Applicative
@@ -44,7 +43,7 @@ isLeft (Right _) = False
4443
--
4544
desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]
4645
desugarCasesModule 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`) $
4847
Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
4948

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

‎src/Language/PureScript/Sugar/Names.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,6 @@ module Language.PureScript.Sugar.Names (
1818

1919
import Data.List (nub)
2020
import Data.Maybe (fromMaybe, isJust, mapMaybe)
21-
import Data.Monoid ((<>))
2221

2322
import Control.Applicative (Applicative(..), (<$>), (<*>))
2423
import Control.Monad.Except
@@ -166,7 +165,7 @@ desugarImports modules = do
166165
-- the module has access to an unfiltered list of its own members.
167166
renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module
168167
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
170169
let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
171170
let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
172171
imports <- resolveImports env m
@@ -233,7 +232,8 @@ renameInModule imports exports (Module mn decls exps) =
233232
updateValue (pos, bound) (Let ds val') = do
234233
let args = mapMaybe letBoundVariable ds
235234
unless (length (nub args) == length args) $
236-
throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing
235+
maybe id rethrowWithPosition pos $
236+
throwError $ mkErrorStack ("Overlapping names in let binding.") Nothing
237237
return ((pos, args ++ bound), Let ds val')
238238
where
239239
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
318318
addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
319319
addModule env (Module mn ds _) = do
320320
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
322322

323323
-- Add a declaration from a module to the global export environment
324324
addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment
@@ -344,7 +344,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
344344
filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment
345345
filterExports mn exps env = do
346346
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
348348
return $ M.insert mn moduleExports' env
349349
where
350350

‎src/Language/PureScript/Sugar/Operators.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,6 @@ import Control.Applicative
3434
import Control.Monad.State
3535
import Control.Monad.Except
3636

37-
import Data.Monoid ((<>))
3837
import Data.Function (on)
3938
import Data.Functor.Identity
4039
import Data.List (groupBy, sortBy)
@@ -90,7 +89,7 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
9089
go [] = return ()
9190
go [_] = return ()
9291
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`) $
9493
rethrowWithPosition pos $
9594
throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
9695
go (_ : rest) = go rest

‎src/Language/PureScript/Sugar/TypeClasses.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,6 @@ import Control.Monad.Except
3838
import Control.Monad.State
3939
import Data.List ((\\), find)
4040
import Data.Maybe (catMaybes, mapMaybe, isJust)
41-
import Data.Monoid ((<>))
4241

4342
import qualified Data.Map as M
4443

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

226225
typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
227226
typeInstanceDictionaryDeclaration 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
229228
m <- get
230229

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

‎src/Language/PureScript/Sugar/TypeDeclarations.hs‎

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -19,8 +19,6 @@ module Language.PureScript.Sugar.TypeDeclarations (
1919
desugarTypeDeclarationsModule
2020
) where
2121

22-
import Data.Monoid ((<>))
23-
2422
import Control.Applicative
2523
import Control.Monad (forM)
2624
import Control.Monad.Except (throwError)
@@ -36,7 +34,7 @@ import Language.PureScript.Traversals
3634
--
3735
desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]
3836
desugarTypeDeclarationsModule 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`) $
4038
Module name <$> desugarTypeDeclarations ds <*> pure exps
4139

4240
-- |

‎src/Language/PureScript/TypeChecker.hs‎

Lines changed: 7 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,6 @@ import Language.PureScript.TypeChecker.Synonyms as T
2727

2828
import Data.Maybe
2929
import Data.List (nub, (\\), find, intercalate)
30-
import Data.Monoid ((<>))
3130
import Data.Foldable (for_)
3231
import qualified Data.Map as M
3332

@@ -47,7 +46,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
4746
env <- getEnv
4847
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
4948
forM_ dctors $ \(dctor, tys) ->
50-
rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
49+
rethrow (mkCompileError ("Error in data constructor " ++ show dctor) Nothing `combineErrors`) $
5150
addDataConstructor moduleName dtype name (map fst args) dctor tys
5251

5352
addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -134,7 +133,7 @@ typeCheckAll mainModuleName moduleName exps = go
134133
go :: [Declaration] -> Check [Declaration]
135134
go [] = return []
136135
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
138137
when (dtype == Newtype) $ checkNewtype dctors
139138
checkDuplicateTypeArguments $ map fst args
140139
ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
@@ -148,7 +147,7 @@ typeCheckAll mainModuleName moduleName exps = go
148147
checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"
149148
checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"
150149
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
152151
let syns = mapMaybe toTypeSynonym tys
153152
let dataDecls = mapMaybe toDataDecl tys
154153
(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
170169
toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
171170
toDataDecl _ = Nothing
172171
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
174173
checkDuplicateTypeArguments $ map fst args
175174
kind <- kindsOf False moduleName name args [ty]
176175
let args' = args `withKinds` kind
@@ -179,7 +178,7 @@ typeCheckAll mainModuleName moduleName exps = go
179178
return $ TypeSynonymDeclaration name args ty : ds
180179
go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
181180
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
183182
valueIsNotDefined moduleName name
184183
[(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
185184
addValue moduleName name ty nameKind
@@ -188,7 +187,7 @@ typeCheckAll mainModuleName moduleName exps = go
188187
return $ d : ds
189188
go (ValueDeclaration{} : _) = error "Binders were not desugared"
190189
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
192191
forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
193192
valueIsNotDefined moduleName name
194193
tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -208,7 +207,7 @@ typeCheckAll mainModuleName moduleName exps = go
208207
ds <- go rest
209208
return $ d : ds
210209
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
212211
env <- getEnv
213212
kind <- kindOf moduleName ty
214213
guardWith (strMsg "Expected kind *") $ kind == Star

‎src/Language/PureScript/TypeChecker/Kinds.hs‎

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,6 @@ module Language.PureScript.TypeChecker.Kinds (
2424
) where
2525

2626
import Data.Maybe (fromMaybe)
27-
import Data.Monoid ((<>))
2827

2928
import qualified Data.HashMap.Strict as H
3029
import qualified Data.Map as M
@@ -79,7 +78,7 @@ kindOf _ ty = fst <$> kindOfWithScopedVars ty
7978
--
8079
kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])
8180
kindOfWithScopedVars ty =
82-
rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $
81+
rethrow (mkCompileError "Error checking kind" (Just (TypeError ty)) `combineErrors`) $
8382
fmap tidyUp . liftUnify $ infer ty
8483
where
8584
tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)
@@ -157,7 +156,7 @@ starIfUnknown k = k
157156
-- Infer a kind for a type
158157
--
159158
infer :: 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
161160

162161
infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])
163162
infer' (ForAll ident ty _) = do

‎src/Language/PureScript/TypeChecker/Subsumption.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,6 @@ module Language.PureScript.TypeChecker.Subsumption (
1818
) where
1919

2020
import Data.List (sortBy)
21-
import Data.Monoid
2221
import Data.Ord (comparing)
2322

2423
import Control.Applicative
@@ -39,7 +38,7 @@ import Language.PureScript.Types
3938
-- Check whether one type subsumes another, rethrowing errors to provide a better error message
4039
--
4140
subsumes :: 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
4342
where
4443
errorMessage = "Error checking that type "
4544
++ prettyPrintType ty1

0 commit comments

Comments
 (0)