2709304 · rowtype-yoga/purescript-native

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

Remove erroneous MonadPlus instance after move to ExceptT.

commit2709304378c5aa325eed4f0161dde6050fe56bcd authorPhil Freeman <paf31@cantab.net> dateFri 20 Feb 2015, 18:06 (12 years ago) parentfe55e94

12 files changed+41−45

compare with golang

unifiedsplit

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

@@ -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 " +

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

114108

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

130127rethrowWithPosition :: (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+1−2

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

2424import Data.Graph

2525import Data.List (nub, intersect)

2626import Data.Maybe (isJust, mapMaybe)

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

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

2928import 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

187186toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

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

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

1919 desugarCasesModule

2020) where

2121

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

2322import Data.List (nub, groupBy)

2423

2524import Control.Applicative

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

4443--

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

4645desugarCasesModule 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

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

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

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

1818

1919import Data.List (nub)

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

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

2221

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

2423import 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

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

345345filterExports 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+1−2

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

3434import Control.Monad.State

3535import Control.Monad.Except

3636

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

3837import Data.Function (on)

3938import Data.Functor.Identity

4039import 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+1−2

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

3838import Control.Monad.State

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

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

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

4241

4342import qualified Data.Map as M

4443

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

225224

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

227226typeInstanceDictionaryDeclaration 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+1−3

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

1919 desugarTypeDeclarationsModule

2020) where

2121

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

23−

2422import Control.Applicative

2523import Control.Monad (forM)

2624import Control.Monad.Except (throwError)

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

3634--

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

3836desugarTypeDeclarationsModule 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+7−8

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

2727

2828import Data.Maybe

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

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

3130import Data.Foldable (for_)

3231import 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

5352addDataConstructor :: 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+2−3

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

2424) where

2525

2626import Data.Maybe (fromMaybe)

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

2827

2928import qualified Data.HashMap.Strict as H

3029import qualified Data.Map as M

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

7978--

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

8180kindOfWithScopedVars 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--

159158infer :: 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

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

163162infer' (ForAll ident ty _) = do

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

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

1818) where

1919

2020import Data.List (sortBy)

21−import Data.Monoid

2221import Data.Ord (comparing)

2322

2423import 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--

4140subsumes :: 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

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

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

3838import Data.Either (lefts, rights)

3939import Data.List

4040import Data.Maybe (fromMaybe)

41−import Data.Monoid

4241import qualified Data.Map as M

4342import Data.String (IsString)

4443

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

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

209208--

210209infer :: 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

212211

213212-- |

214213-- Infer a type for a value

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

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

429428--

430429check :: 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

432431 where

433432 errorMessage =

434433 "Error checking type of term " ++

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

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

611610--

612611checkFunctionApplication :: 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

614613 subst <- unifyCurrentSubstitution <$> UnifyT get

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

616615 where

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

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

2727

2828import Data.List (nub, sort)

2929import Data.Maybe (fromMaybe)

30−import Data.Monoid

3130import qualified Data.HashMap.Strict as H

3231

3332import Control.Monad.Except

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

6160-- Unify two types, updating the current substitution

6261--

6362unifyTypes :: 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`) $

6564 unifyTypes' t1 t2

6665 where

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