af0492a · rowtype-yoga/purescript-native

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

Merge pull request #666 from purescript/524

Multiple errors during name resolution

commitaf0492a83e14cacdbd7936f765b2211491ac825d authorPhil Freeman <paf31@cantab.net> dateSat 1 Nov 2014, 16:16 (12 years ago) parent33db511 80312da

9 files changed+31−26

compare with golang

unifiedsplit

examples/failing/MultipleErrors2.purs+5 src/Language/PureScript/Errors.hs+17 src/Language/PureScript/Sugar/BindingGroups.hs+3−3 src/Language/PureScript/Sugar/CaseDeclarations.hs+2−2 src/Language/PureScript/Sugar/DoNotation.hs+1−1 src/Language/PureScript/Sugar/Names.hs+1−1 src/Language/PureScript/Sugar/Operators.hs+1−1 src/Language/PureScript/Sugar/TypeClasses.hs+1−1 src/Language/PureScript/TypeChecker/Monad.hs−17

examples/failing/MultipleErrors2.pursnew file+5

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

1+module MultipleErrors2 where

3+foo = itDoesntExist

5+bar = neitherDoesThis

src/Language/PureScript/Errors.hs+17

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

1616

1717module Language.PureScript.Errors where

1818

19+import Data.Either (lefts, rights)

1920import Data.List (intersperse, intercalate)

2021import Data.Monoid

2122

2223import Control.Monad.Error

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

2325

2426import Language.PureScript.Declarations

2527import Language.PureScript.Pretty

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

121123--

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

123125rethrowWithPosition 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

5252--

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

5454createBindingGroups moduleName ds = do

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

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

5656 let dataDecls = filter isDataDecl ds

5757 allProperNames = map getProperName dataDecls

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

59− dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

59+ dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

6060 let allIdents = map getIdent values

6161 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)

6363 return $ filter isImportDecl ds ++

6464 filter isExternDataDecl ds ++

6565 filter isExternInstanceDecl ds ++

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

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

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

4444

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

46−desugarAbs = mapM f

46+desugarAbs = flip parU f

4747 where

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

4949

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

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

5858--

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

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

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

6161 where

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

6363 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

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

3434--

3535desugarDoModule :: 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

3737

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

3939desugarDo (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 $

176176--

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

178178renameInModule imports exports (Module mn decls exps) =

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

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

180180 where

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

182182

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

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

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

6767rebracketModule opTable (Module mn ds exts) =

6868 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

7070

7171removeParens :: Declaration -> Declaration

7272removeParens =

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

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

5353

5454desugarModule :: Module -> Desugar Module

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

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

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

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

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

5959

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

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

2828import Language.PureScript.Errors

2929

3030import Data.Maybe

31−import Data.Either (lefts, rights)

3231

3332import Control.Applicative

3433import Control.Monad.State

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

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

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

235234 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−