af0492a · rowtype-yoga/purescript-native

examples/failing/MultipleErrors2.pursnew file+5

compare with golang

unifiedsplit

@@ -0,0 +1,5 @@

1+module MultipleErrors2 where

2+

3+foo = itDoesntExist

4+

5+bar = neitherDoesThis

src/Language/PureScript/Errors.hs+17

@@ -16,10 +16,12 @@

16

17module Language.PureScript.Errors where

18

19+import Data.Either (lefts, rights)

19import Data.List (intersperse, intercalate)

20import Data.List (intersperse, intercalate)

20import Data.Monoid

21import Data.Monoid

21

22

22import Control.Monad.Error

23import Control.Monad.Error

24+import Control.Applicative ((<$>))

23

25

24import Language.PureScript.Declarations

26import Language.PureScript.Declarations

25import Language.PureScript.Pretty

27import Language.PureScript.Pretty

@@ -121,3 +123,18 @@ rethrow f = flip catchError $ \e -> throwError (f e)

121--

123--

122rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a

124rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a

123rethrowWithPosition pos = rethrow (positionError pos <>)

125rethrowWithPosition pos = rethrow (positionError pos <>)

126+

127+-- |

128+-- Collect errors in in parallel

129+--

130+parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]

131+parU xs f = forM xs (withError . f) >>= collectErrors

132+ where

133+ withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)

134+ withError u = catchError (Right <$> u) (return . Left)

135+

136+ collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]

137+ collectErrors es = case lefts es of

138+ [err] -> throwError err

139+ [] -> return $ rights es

140+ errs -> throwError $ MultipleErrors errs

src/Language/PureScript/Sugar/BindingGroups.hs+3−3

@@ -52,14 +52,14 @@ collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (colla

52--

53createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]

54createBindingGroups moduleName ds = do

55− values <- mapM (createBindingGroupsForValue moduleName) $ filter isValueDecl ds

55+ values <- parU (filter isValueDecl ds) (createBindingGroupsForValue moduleName)

56 let dataDecls = filter isDataDecl ds

57 allProperNames = map getProperName dataDecls

58 dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls

59− dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

59+ dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

60 let allIdents = map getIdent values

61 valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values

62− bindingGroupDecls <- mapM (toBindingGroup moduleName) $ stronglyConnComp valueVerts

62+ bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)

63 return $ filter isImportDecl ds ++

64 filter isExternDataDecl ds ++

65 filter isExternInstanceDecl ds ++

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

@@ -43,7 +43,7 @@ desugarCasesModule ms = forM ms $ \(Module name ds exps) ->

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

44

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

46−desugarAbs = mapM f

46+desugarAbs = flip parU f

47 where

48 (f, _, _) = everywhereOnValuesM return replace return

49

@@ -57,7 +57,7 @@ desugarAbs = mapM f

57-- Replace all top-level binders with case expressions.

58--

59desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

60−desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup

60+desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

61 where

62 desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

63 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

src/Language/PureScript/Sugar/DoNotation.hs+1−1

@@ -33,7 +33,7 @@ import Control.Monad.Trans.Class

33-- and all @DoNotationLet@ constructors with let expressions.

34--

35desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module

36−desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts

36+desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts

37

38desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration

39desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)

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

@@ -176,7 +176,7 @@ elaborateExports exps (Module mn decls _) = Module mn decls (Just $

176--

177renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module

178renameInModule imports exports (Module mn decls exps) =

179− Module mn <$> mapM go decls <*> pure exps

179+ Module mn <$> parU decls go <*> pure exps

180 where

181 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

182

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

@@ -66,7 +66,7 @@ removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts

66rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module

67rebracketModule opTable (Module mn ds exts) =

68 let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return

69− in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts

69+ in Module mn <$> (map removeParens <$> parU ds f) <*> pure exts

70

71removeParens :: Declaration -> Declaration

72removeParens =

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

@@ -53,7 +53,7 @@ desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

53

54desugarModule :: Module -> Desugar Module

55desugarModule (Module name decls (Just exps)) = do

56− (newExpss, declss) <- unzip <$> mapM (desugarDecl name exps) decls

56+ (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)

57 return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)

58desugarModule _ = error "Exports should have been elaborated in name desugaring"

59

src/Language/PureScript/TypeChecker/Monad.hs−17

@@ -28,7 +28,6 @@ import Language.PureScript.Options

28import Language.PureScript.Errors

29

30import Data.Maybe

31−import Data.Either (lefts, rights)

32

31

33import Control.Applicative

32import Control.Applicative

34import Control.Monad.State

33import Control.Monad.State

@@ -233,19 +232,3 @@ liftUnify unify = do

233 (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify

232 (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify

234 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

233 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

235 return (a, unifyCurrentSubstitution ust)

234 return (a, unifyCurrentSubstitution ust)

236−

237−-- |

238−-- Typecheck in parallel

239−--

240−parU :: [a] -> (a -> UnifyT t Check b) -> UnifyT t Check [b]

241−parU xs f = forM xs (withError . f) >>= collectErrors

242− where

243− withError :: UnifyT t Check a -> UnifyT t Check (Either ErrorStack a)

244− withError u = catchError (Right <$> u) (return . Left)

245−

246− collectErrors :: [Either ErrorStack a] -> UnifyT t Check [a]

247− collectErrors es = case lefts es of

248− [err] -> throwError err

249− [] -> return $ rights es

250− errs -> throwError $ MultipleErrors errs

251−