49fac78 · rowtype-yoga/purescript-native

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

on golang help sign in

Tidy up MonadError code a bit more

49fac78Phil Freeman12 years ago

psc-make/Main.hs+13−11

compare with golang

unifiedsplit

@@ -52,27 +52,29 @@ readInput InputOptions{..} = do

52 content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile

53 return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)

55−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }

55+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT P.MultipleErrors IO) a }

56− deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make))

56+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make))

58−runMake :: P.Options P.Make -> Make a -> IO (Either String a)

58+runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors a)

59runMake opts = runExceptT . flip runReaderT opts . unMake

61−makeIO :: IO a -> Make a

61+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a

62−makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError

62+makeIO f io = do

63+ e <- liftIO $ tryIOError io

64+ either (throwError . P.errorMessage . f) return e

64instance P.MonadMake Make where

66instance P.MonadMake Make where

65− getTimestamp path = makeIO $ do

67+ getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do

66 exists <- doesFileExist path

68 exists <- doesFileExist path

67 traverse (const $ getModificationTime path) $ guard exists

69 traverse (const $ getModificationTime path) $ guard exists

68− readTextFile path = makeIO $ do

70+ readTextFile path = makeIO (const (P.CannotReadFile path))$ do

69 putStrLn $ "Reading " ++ path

71 putStrLn $ "Reading " ++ path

70 readFile path

72 readFile path

71− writeTextFile path text = makeIO $ do

73+ writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do

72 mkdirp path

74 mkdirp path

73 putStrLn $ "Writing " ++ path

75 putStrLn $ "Writing " ++ path

74 writeFile path text

76 writeFile path text

75− progress = makeIO . putStrLn

77+ progress = liftIO . putStrLn

77compile :: PSCMakeOptions -> IO ()

79compile :: PSCMakeOptions -> IO ()

78compile (PSCMakeOptions input outputDir opts usePrefix) = do

80compile (PSCMakeOptions input outputDir opts usePrefix) = do

@@ -84,8 +86,8 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do

84 Right ms -> do

86 Right ms -> do

85 e <- runMake opts $ P.make outputDir ms prefix

87 e <- runMake opts $ P.make outputDir ms prefix

86 case e of

88 case e of

87− Left err -> do

89+ Left errs -> do

88− putStrLn err

90+ putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

89 exitFailure

91 exitFailure

90 Right _ -> do

92 Right _ -> do

91 exitSuccess

93 exitSuccess

psc/Main.hs+2−2

@@ -63,8 +63,8 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do

63 exitFailure

64 Right ms -> do

65 case P.compile (map snd ms) prefix `runReaderT` opts of

66− Left err -> do

66+ Left errs -> do

67− hPutStrLn stderr err

67+ hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

68 exitFailure

69 Right (js, exts, _) -> do

70 case output of

psci/PSCi.hs+23−15

@@ -29,6 +29,8 @@ import qualified Data.Map as M

30import Control.Applicative

31import Control.Monad

32+import Control.Monad.IO.Class (MonadIO, liftIO)

33+import Control.Monad.Error.Class (throwError)

32import Control.Monad.Except (ExceptT(..), MonadError, runExceptT)

34import Control.Monad.Except (ExceptT(..), MonadError, runExceptT)

33import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)

35import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)

34import Control.Monad.Trans.Class

36import Control.Monad.Trans.Class

@@ -180,24 +182,26 @@ newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Fu

180psciIO :: IO a -> PSCI a

182psciIO :: IO a -> PSCI a

181psciIO io = PSCI . lift $ lift io

183psciIO io = PSCI . lift $ lift io

182

184

183−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }

185+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT P.MultipleErrors IO) a }

184− deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make))

186+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make))

185

187

186−runMake :: Make a -> IO (Either String a)

188+runMake :: Make a -> IO (Either P.MultipleErrors a)

187runMake = runExceptT . flip runReaderT options . unMake

189runMake = runExceptT . flip runReaderT options . unMake

188

190

189−makeIO :: IO a -> Make a

191+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a

190−makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError

192+makeIO f io = do

193+ e <- liftIO $ tryIOError io

194+ either (throwError . P.errorMessage . f) return e

191

195

192instance P.MonadMake Make where

196instance P.MonadMake Make where

193− getTimestamp path = makeIO $ do

197+ getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do

194 exists <- doesFileExist path

198 exists <- doesFileExist path

195 traverse (const $ getModificationTime path) $ guard exists

199 traverse (const $ getModificationTime path) $ guard exists

196− readTextFile path = makeIO $ readFile path

200+ readTextFile path = makeIO (const (P.CannotReadFile path)) $ readFile path

197− writeTextFile path text = makeIO $ do

201+ writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do

198 mkdirp path

202 mkdirp path

199 writeFile path text

203 writeFile path text

200− progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s

204+ progress s = unless (s == "Compiling $PSCI") $ liftIO . putStrLn $ s

201

205

202mkdirp :: FilePath -> IO ()

206mkdirp :: FilePath -> IO ()

203mkdirp = createDirectoryIfMissing True . takeDirectory

207mkdirp = createDirectoryIfMissing True . takeDirectory

@@ -259,7 +263,7 @@ handleDeclaration val = do

259 let nodeArgs = psciNodeFlags st ++ [indexFile]

263 let nodeArgs = psciNodeFlags st ++ [indexFile]

260 e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

264 e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

261 case e of

265 case e of

262− Left err -> PSCI $ outputStrLn err

266+ Left errs -> printErrors errs

263 Right _ -> do

267 Right _ -> do

264 psciIO $ writeFile indexFile "require('$PSCI').main();"

268 psciIO $ writeFile indexFile "require('$PSCI').main();"

265 process <- psciIO findNodeProcess

269 process <- psciIO findNodeProcess

@@ -280,7 +284,7 @@ handleDecls ds = do

280 let m = createTemporaryModule False st' (P.ObjectLiteral [])

284 let m = createTemporaryModule False st' (P.ObjectLiteral [])

281 e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []

285 e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []

282 case e of

286 case e of

283− Left err -> PSCI $ outputStrLn err

287+ Left err -> printErrors err

284 Right _ -> PSCI $ lift (put st')

288 Right _ -> PSCI $ lift (put st')

285

289

286-- |

290-- |

@@ -333,7 +337,7 @@ handleImport im = do

333 let m = createTemporaryModuleForImports st

337 let m = createTemporaryModuleForImports st

334 e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

338 e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

335 case e of

339 case e of

336− Left err -> PSCI $ outputStrLn err

340+ Left errs -> printErrors errs

337 Right _ -> do

341 Right _ -> do

338 PSCI $ lift $ put st

342 PSCI $ lift $ put st

339 return ()

343 return ()

@@ -347,7 +351,7 @@ handleTypeOf val = do

347 let m = createTemporaryModule False st val

351 let m = createTemporaryModule False st val

348 e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

352 e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

349 case e of

353 case e of

350− Left err -> PSCI $ outputStrLn err

354+ Left errs -> printErrors errs

351 Right env' ->

355 Right env' ->

352 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

356 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

353 Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

357 Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

@@ -381,12 +385,16 @@ handleBrowse moduleName = do

381 let loadedModules = psciLoadedModules st

385 let loadedModules = psciLoadedModules st

382 env <- psciIO . runMake $ P.make modulesDir loadedModules []

386 env <- psciIO . runMake $ P.make modulesDir loadedModules []

383 case env of

387 case env of

384− Left err -> PSCI $ outputStrLn err

388+ Left errs -> printErrors errs

385 Right env' ->

389 Right env' ->

386 if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules

390 if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules

387 then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."

391 then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."

388 else printModuleSignatures moduleName env'

392 else printModuleSignatures moduleName env'

389

393

394+-- | Pretty-print errors

395+printErrors :: P.MultipleErrors -> PSCI ()

396+printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False

397+

390-- |

398-- |

391-- Takes a value and prints its kind

399-- Takes a value and prints its kind

392--

400--

@@ -397,7 +405,7 @@ handleKindOf typ = do

397 mName = P.ModuleName [P.ProperName "$PSCI"]

405 mName = P.ModuleName [P.ProperName "$PSCI"]

398 e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

406 e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

399 case e of

407 case e of

400− Left err -> PSCI $ outputStrLn err

408+ Left errs -> printErrors errs

401 Right env' ->

409 Right env' ->

402 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

410 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

403 Just (_, typ') -> do

411 Just (_, typ') -> do

src/Language/PureScript.hs+11−11

@@ -89,20 +89,20 @@ import qualified Paths_purescript as Paths

89--

90-- * Pretty-print the generated Javascript

91--

92−compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)

92+compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m)

93 => [Module] -> [String] -> m (String, String, Environment)

94compile = compile' initEnvironment

96−compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)

96+compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m)

97 => Environment -> [Module] -> [String] -> m (String, String, Environment)

98compile' env ms prefix = do

99 noPrelude <- asks optionsNoPrelude

100 additional <- asks optionsAdditional

101 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)

102 (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms

103− (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted

103+ (desugared, nextVar) <- runSupplyT 0 $ desugar sorted

104 (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent

105− regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

105+ regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

106 let corefn = map (CoreFn.moduleToCoreFn env') regrouped

107 let entryPoints = moduleNameFromString `map` entryPointModules additional

108 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn

@@ -115,21 +115,21 @@ compile' env ms prefix = do

115 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']

116 return (pjs, exts, env')

117

118−generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]

118+generateMain :: (MonadError MultipleErrors m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]

119generateMain env js = do

120 main <- asks optionsMain

121 additional <- asks optionsAdditional

122 case moduleNameFromString <$> main of

123 Just mmi -> do

124 when ((mmi, Ident C.main) `M.notMember` names env) $

125− throwError $ show mmi ++ "." ++ C.main ++ " is undefined"

125+ throwError . errorMessage $ NameIsUndefined (Ident C.main)

126 return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]

127 _ -> return js

128

129-- |

130-- A type class which collects the IO actions we need to be able to run in "make" mode

131--

132−class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where

132+class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m) => MonadMake m where

133 -- |

134 -- Get a file timestamp

135 --

@@ -196,7 +196,7 @@ make outputDir ms prefix = do

196

197 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

198

199− (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

199+ (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

200

201 evalSupplyT nextVar $ go initEnvironment desugared

202

@@ -216,7 +216,7 @@ make outputDir ms prefix = do

216

217 (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m

218

219− regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

219+ regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

220

221 let mod' = Module coms moduleName' regrouped exps

222 let corefn = CoreFn.moduleToCoreFn env' mod'

@@ -240,10 +240,10 @@ make outputDir ms prefix = do

240 rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do

241 let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"

242 externs <- readTextFile externsFile

243− externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]

243+ externsModules <- fmap (map snd) . either (throwError . errorMessage . ErrorParsingExterns) return $ P.parseModulesFromFiles id [(externsFile, externs)]

244 case externsModules of

245 [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'

246− _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"

246+ _ -> throwError . errorMessage . InvalidExternsFile $ externsFile

247

248reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]

249reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

src/Language/PureScript/Errors.hs+33−3

@@ -36,11 +36,18 @@ import Language.PureScript.TypeClassDictionaries

37import qualified Text.PrettyPrint.Boxes as Box

39+import qualified Text.Parsec as P

40+

39-- |

41-- |

40-- A type of error messages

42-- A type of error messages

41--

43--

42data ErrorMessage

44data ErrorMessage

45+ = ErrorParsingExterns P.ParseError

46+ | InvalidExternsFile FilePath

47+ | CannotGetFileInfo FilePath

48+ | CannotReadFile FilePath

49+ | CannotWriteFile FilePath

43− = InfiniteType Type

50+ | InfiniteType Type

44 | InfiniteKind Kind

51 | InfiniteKind Kind

45 | CannotReorderOperators

52 | CannotReorderOperators

46 | MultipleFixities Ident

53 | MultipleFixities Ident

@@ -70,6 +77,7 @@ data ErrorMessage

70 | InvalidDoLet

77 | InvalidDoLet

71 | CycleInDeclaration Ident

78 | CycleInDeclaration Ident

72 | CycleInTypeSynonym (Maybe ProperName)

79 | CycleInTypeSynonym (Maybe ProperName)

80+ | CycleInModules [ModuleName]

73 | NameIsUndefined Ident

81 | NameIsUndefined Ident

74 | NameNotInScope Ident

82 | NameNotInScope Ident

75 | UndefinedTypeVariable ProperName

83 | UndefinedTypeVariable ProperName

@@ -126,6 +134,11 @@ instance UnificationError Kind ErrorMessage where

126-- Get the error code for a particular error type

134-- Get the error code for a particular error type

127--

135--

128errorCode :: ErrorMessage -> String

136errorCode :: ErrorMessage -> String

137+errorCode (ErrorParsingExterns _) = "ErrorParsingExterns"

138+errorCode (InvalidExternsFile _) = "InvalidExternsFile"

139+errorCode (CannotGetFileInfo _) = "CannotGetFileInfo"

140+errorCode (CannotReadFile _) = "CannotReadFile"

141+errorCode (CannotWriteFile _) = "CannotWriteFile"

129errorCode (InfiniteType _) = "InfiniteType"

142errorCode (InfiniteType _) = "InfiniteType"

130errorCode (InfiniteKind _) = "InfiniteKind"

143errorCode (InfiniteKind _) = "InfiniteKind"

131errorCode CannotReorderOperators = "CannotReorderOperators"

144errorCode CannotReorderOperators = "CannotReorderOperators"

@@ -156,6 +169,7 @@ errorCode InvalidDoBind = "InvalidDoBind"

156errorCode InvalidDoLet = "InvalidDoLet"

169errorCode InvalidDoLet = "InvalidDoLet"

157errorCode (CycleInDeclaration _) = "CycleInDeclaration"

170errorCode (CycleInDeclaration _) = "CycleInDeclaration"

158errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"

171errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"

172+errorCode (CycleInModules _) = "CycleInModules"

159errorCode (NameIsUndefined _) = "NameIsUndefined"

173errorCode (NameIsUndefined _) = "NameIsUndefined"

160errorCode (NameNotInScope _) = "NameNotInScope"

174errorCode (NameNotInScope _) = "NameNotInScope"

161errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"

175errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"

@@ -245,6 +259,21 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim

245 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

259 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

246

260

247 go :: ErrorMessage -> Box.Box

261 go :: ErrorMessage -> Box.Box

262+ go (CannotGetFileInfo path) = paras [ line "Unable to read file info: "

263+ , indent . line $ path

264+ ]

265+ go (CannotReadFile path) = paras [ line "Unable to read file: "

266+ , indent . line $ path

267+ ]

268+ go (CannotWriteFile path) = paras [ line "Unable to write file: "

269+ , indent . line $ path

270+ ]

271+ go (ErrorParsingExterns err) = paras [ line "Error parsing externs files: "

272+ , indent . line . show $ err

273+ ]

274+ go (InvalidExternsFile path) = paras [ line "Externs file is invalid: "

275+ , indent . line $ path

276+ ]

248 go InvalidDoBind = line "Bind statement cannot be the last statement in a do block"

277 go InvalidDoBind = line "Bind statement cannot be the last statement in a do block"

249 go InvalidDoLet = line "Let statement cannot be the last statement in a do block"

278 go InvalidDoLet = line "Let statement cannot be the last statement in a do block"

250 go CannotReorderOperators = line "Unable to reorder operators"

279 go CannotReorderOperators = line "Unable to reorder operators"

@@ -278,6 +307,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim

278 go (DuplicateClassExport nm) = line $ "Duplicate export declaration for type class " ++ show nm

307 go (DuplicateClassExport nm) = line $ "Duplicate export declaration for type class " ++ show nm

279 go (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ show nm

308 go (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ show nm

280 go (CycleInDeclaration nm) = line $ "Cycle in declaration of " ++ show nm

309 go (CycleInDeclaration nm) = line $ "Cycle in declaration of " ++ show nm

310+ go (CycleInModules mns) = line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns)

281 go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"

311 go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"

282 , indent $ go err

312 , indent $ go err

283 ]

313 ]

@@ -490,8 +520,8 @@ renderBox = unlines . map trimEnd . lines . Box.render

490-- |

520-- |

491-- Interpret multiple errors in a monad supporting errors

521-- Interpret multiple errors in a monad supporting errors

492--

522--

493−interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a

523+interpretMultipleErrors :: (MonadError MultipleErrors m) => Either MultipleErrors a -> m a

494−interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return

524+interpretMultipleErrors = either throwError return

495

525

496-- |

526-- |

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

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

src/Language/PureScript/ModuleDependencies.hs+4−3

@@ -28,6 +28,7 @@ import Data.Maybe (mapMaybe)

28import Language.PureScript.AST

29import Language.PureScript.Names

30import Language.PureScript.Types

31+import Language.PureScript.Errors

32-- |

33-- |

33-- A list of modules with their dependencies

34-- A list of modules with their dependencies

@@ -39,7 +40,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]

39--

40--

40-- Reports an error if the module graph contains a cycle.

41-- Reports an error if the module graph contains a cycle.

41--

42--

42−sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph)

43+sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)

43sortModules ms = do

44sortModules ms = do

44 let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms

45 let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms

45 ms' <- mapM toModule $ stronglyConnComp verts

46 ms' <- mapM toModule $ stronglyConnComp verts

@@ -70,7 +71,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (

70-- |

71-- |

71-- Convert a strongly connected component of the module graph to a module

72-- Convert a strongly connected component of the module graph to a module

72--

73--

73−toModule :: (MonadError String m) => SCC Module -> m Module

74+toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module

74toModule (AcyclicSCC m) = return m

75toModule (AcyclicSCC m) = return m

75toModule (CyclicSCC [m]) = return m

76toModule (CyclicSCC [m]) = return m

76−toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms)

77+toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)

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

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

24import Data.List (nub, groupBy)

26import Control.Applicative

27−import Control.Monad ((<=<), forM, join, unless, replicateM)

27+import Control.Monad ((<=<), forM, join, unless)

28import Control.Monad.Except (throwError)

29import Control.Monad.Error.Class (MonadError)

30import Control.Monad.Supply.Class

src/Language/PureScript/TypeChecker/Monad.hs+5−9

@@ -23,7 +23,6 @@ import qualified Data.Map as M

24import Control.Applicative

25import Control.Monad.Except

26−import Control.Monad.Reader.Class

27import Control.Monad.State

26import Control.Monad.State

28import Control.Monad.Unify

27import Control.Monad.Unify

@@ -31,7 +30,6 @@ import Language.PureScript.Environment

31import Language.PureScript.Errors

30import Language.PureScript.Errors

32import Language.PureScript.Kinds

31import Language.PureScript.Kinds

33import Language.PureScript.Names

32import Language.PureScript.Names

34−import Language.PureScript.Options

35import Language.PureScript.TypeClassDictionaries

33import Language.PureScript.TypeClassDictionaries

36import Language.PureScript.Types

34import Language.PureScript.Types

@@ -195,18 +193,16 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

195-- |

193-- |

196-- Run a computation in the Check monad, starting with an empty @Environment@

194-- Run a computation in the Check monad, starting with an empty @Environment@

197--

195--

198−runCheck :: (MonadReader (Options mode) m, MonadError String m) => Check a -> m (a, Environment)

196+runCheck :: (MonadError MultipleErrors m) => Check a -> m (a, Environment)

199runCheck = runCheck' initEnvironment

197runCheck = runCheck' initEnvironment

200

198

201-- |

199-- |

202-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

200-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

203--

201--

204−runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)

202+runCheck' :: (MonadError MultipleErrors m) => Environment -> Check a -> m (a, Environment)

205−runCheck' env c = do

206− verbose <- asks optionsVerboseErrors

207− interpretMultipleErrors verbose $ do

203+runCheck' env c = interpretMultipleErrors $ do

208− (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

204+ (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

209− return (a, checkEnv s)

205+ return (a, checkEnv s)

210

206

211-- |

207-- |

212-- Make an assertion, failing with an error message

208-- Make an assertion, failing with an error message