35462a0 · rowtype-yoga/purescript-native

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

Merge pull request #999 from purescript/error-tidying

Tidy up MonadError code a bit more

commit35462a06df7094ce086faca82c0225becedbb02d authorPhil Freeman <paf31@cantab.net> dateWed 25 Mar 2015, 09:26 (12 years ago) parent8f8615b 44028b3

9 files changed+105−63

compare with golang

unifiedsplit

psc-make/Main.hs+13−11 psc/Main.hs+2−2 psci/PSCi.hs+23−15 src/Language/PureScript.hs+11−11 src/Language/PureScript/Errors.hs+38−3 src/Language/PureScript/ModuleDependencies.hs+4−3 src/Language/PureScript/Sugar/CaseDeclarations.hs+1−1 src/Language/PureScript/TypeChecker/Monad.hs+5−9 tests/Main.hs+8−8

psc-make/Main.hs+13−11

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

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

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

5454

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

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

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

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

5757

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)

5959runMake opts = runExceptT . flip runReaderT opts . unMake

6060

61−makeIO :: IO a -> Make a

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

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

62+makeIO f io = do

63+ e <- liftIO $ tryIOError io

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

6365

6466instance P.MonadMake Make where

65− getTimestamp path = makeIO $ do

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

6668 exists <- doesFileExist path

6769 traverse (const $ getModificationTime path) $ guard exists

68− readTextFile path = makeIO $ do

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

6971 putStrLn $ "Reading " ++ path

7072 readFile path

71− writeTextFile path text = makeIO $ do

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

7274 mkdirp path

7375 putStrLn $ "Writing " ++ path

7476 writeFile path text

75− progress = makeIO . putStrLn

77+ progress = liftIO . putStrLn

7678

7779compile :: PSCMakeOptions -> IO ()

7880compile (PSCMakeOptions input outputDir opts usePrefix) = do

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

8486 Right ms -> do

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

8688 case e of

87− Left err -> do

88− putStrLn err

89+ Left errs -> do

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

8991 exitFailure

9092 Right _ -> do

9193 exitSuccess

psc/Main.hs+2−2

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

6363 exitFailure

6464 Right ms -> do

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

66− Left err -> do

67− hPutStrLn stderr err

66+ Left errs -> do

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

6868 exitFailure

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

7070 case output of

psci/PSCi.hs+23−15

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

2929

3030import Control.Applicative

3131import Control.Monad

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

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

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

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

3436import Control.Monad.Trans.Class

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

180182psciIO :: IO a -> PSCI a

181183psciIO io = PSCI . lift $ lift io

182184

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

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

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

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

185187

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

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

187189runMake = runExceptT . flip runReaderT options . unMake

188190

189−makeIO :: IO a -> Make a

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

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

192+makeIO f io = do

193+ e <- liftIO $ tryIOError io

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

191195

192196instance P.MonadMake Make where

193− getTimestamp path = makeIO $ do

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

194198 exists <- doesFileExist path

195199 traverse (const $ getModificationTime path) $ guard exists

196− readTextFile path = makeIO $ readFile path

197− writeTextFile path text = makeIO $ do

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

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

198202 mkdirp path

199203 writeFile path text

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

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

201205

202206mkdirp :: FilePath -> IO ()

203207mkdirp = createDirectoryIfMissing True . takeDirectory

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

259263 let nodeArgs = psciNodeFlags st ++ [indexFile]

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

261265 case e of

262− Left err -> PSCI $ outputStrLn err

266+ Left errs -> printErrors errs

263267 Right _ -> do

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

265269 process <- psciIO findNodeProcess

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

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

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

282286 case e of

283− Left err -> PSCI $ outputStrLn err

287+ Left err -> printErrors err

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

285289

286290-- |

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

333337 let m = createTemporaryModuleForImports st

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

335339 case e of

336− Left err -> PSCI $ outputStrLn err

340+ Left errs -> printErrors errs

337341 Right _ -> do

338342 PSCI $ lift $ put st

339343 return ()

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

347351 let m = createTemporaryModule False st val

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

349353 case e of

350− Left err -> PSCI $ outputStrLn err

354+ Left errs -> printErrors errs

351355 Right env' ->

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

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

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

381385 let loadedModules = psciLoadedModules st

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

383387 case env of

384− Left err -> PSCI $ outputStrLn err

388+ Left errs -> printErrors errs

385389 Right env' ->

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

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

388392 else printModuleSignatures moduleName env'

389393

394+-- | Pretty-print errors

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

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

397+

390398-- |

391399-- Takes a value and prints its kind

392400--

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

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

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

399407 case e of

400− Left err -> PSCI $ outputStrLn err

408+ Left errs -> printErrors errs

401409 Right env' ->

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

403411 Just (_, typ') -> do

src/Language/PureScript.hs+11−11

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

8989--

9090-- * Pretty-print the generated Javascript

9191--

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)

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

9494compile = compile' initEnvironment

9595

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)

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

9898compile' env ms prefix = do

9999 noPrelude <- asks optionsNoPrelude

100100 additional <- asks optionsAdditional

101101 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)

102102 (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

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

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

105+ regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

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

107107 let entryPoints = moduleNameFromString `map` entryPointModules additional

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

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

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

116116 return (pjs, exts, env')

117117

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]

119119generateMain env js = do

120120 main <- asks optionsMain

121121 additional <- asks optionsAdditional

122122 case moduleNameFromString <$> main of

123123 Just mmi -> do

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

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

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

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

127127 _ -> return js

128128

129129-- |

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

131131--

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

133133 -- |

134134 -- Get a file timestamp

135135 --

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

196196

197197 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

198198

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)

200200

201201 evalSupplyT nextVar $ go initEnvironment desugared

202202

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

216216

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

218218

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

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

220220

221221 let mod' = Module coms moduleName' regrouped exps

222222 let corefn = CoreFn.moduleToCoreFn env' mod'

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

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

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

242242 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)]

244244 case externsModules of

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

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

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

247247

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

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

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

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

3636

3737import qualified Text.PrettyPrint.Boxes as Box

3838

39+import qualified Text.Parsec as P

40+

3941-- |

4042-- A type of error messages

4143--

4244data ErrorMessage

43− = InfiniteType Type

45+ = ErrorParsingExterns P.ParseError

46+ | ErrorParsingPrelude P.ParseError

47+ | InvalidExternsFile FilePath

48+ | CannotGetFileInfo FilePath

49+ | CannotReadFile FilePath

50+ | CannotWriteFile FilePath

51+ | InfiniteType Type

4452 | InfiniteKind Kind

4553 | CannotReorderOperators

4654 | MultipleFixities Ident

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

7078 | InvalidDoLet

7179 | CycleInDeclaration Ident

7280 | CycleInTypeSynonym (Maybe ProperName)

81+ | CycleInModules [ModuleName]

7382 | NameIsUndefined Ident

7483 | NameNotInScope Ident

7584 | UndefinedTypeVariable ProperName

@@ -126,6 +135,12 @@ instance UnificationError Kind ErrorMessage where

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

127136--

128137errorCode :: ErrorMessage -> String

138+errorCode (ErrorParsingExterns _) = "ErrorParsingExterns"

139+errorCode (ErrorParsingPrelude _) = "ErrorParsingPrelude"

140+errorCode (InvalidExternsFile _) = "InvalidExternsFile"

141+errorCode (CannotGetFileInfo _) = "CannotGetFileInfo"

142+errorCode (CannotReadFile _) = "CannotReadFile"

143+errorCode (CannotWriteFile _) = "CannotWriteFile"

129144errorCode (InfiniteType _) = "InfiniteType"

130145errorCode (InfiniteKind _) = "InfiniteKind"

131146errorCode CannotReorderOperators = "CannotReorderOperators"

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

156171errorCode InvalidDoLet = "InvalidDoLet"

157172errorCode (CycleInDeclaration _) = "CycleInDeclaration"

158173errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"

174+errorCode (CycleInModules _) = "CycleInModules"

159175errorCode (NameIsUndefined _) = "NameIsUndefined"

160176errorCode (NameNotInScope _) = "NameNotInScope"

161177errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"

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

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

246262

247263 go :: ErrorMessage -> Box.Box

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

265+ , indent . line $ path

266+ ]

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

268+ , indent . line $ path

269+ ]

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

271+ , indent . line $ path

272+ ]

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

274+ , indent . line . show $ err

275+ ]

276+ go (ErrorParsingPrelude err) = paras [ line "Error parsing prelude: "

277+ , indent . line . show $ err

278+ ]

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

280+ , indent . line $ path

281+ ]

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

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

250284 go CannotReorderOperators = line "Unable to reorder operators"

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

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

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

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

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

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

282317 , indent $ go err

283318 ]

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

490525-- |

491526-- Interpret multiple errors in a monad supporting errors

492527--

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

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

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

529+interpretMultipleErrors = either throwError return

495530

496531-- |

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

2828import Language.PureScript.AST

2929import Language.PureScript.Names

3030import Language.PureScript.Types

31+import Language.PureScript.Errors

3132

3233-- |

3334-- A list of modules with their dependencies

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

3940--

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

4142--

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

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

4344sortModules ms = do

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

4546 ms' <- mapM toModule $ stronglyConnComp verts

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

7071-- |

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

7273--

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

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

7475toModule (AcyclicSCC m) = return m

7576toModule (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 (

2424import Data.List (nub, groupBy)

2525

2626import Control.Applicative

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

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

2828import Control.Monad.Except (throwError)

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

3030import Control.Monad.Supply.Class

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

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

2323

2424import Control.Applicative

2525import Control.Monad.Except

26−import Control.Monad.Reader.Class

2726import Control.Monad.State

2827import Control.Monad.Unify

2928

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

3130import Language.PureScript.Errors

3231import Language.PureScript.Kinds

3332import Language.PureScript.Names

34−import Language.PureScript.Options

3533import Language.PureScript.TypeClassDictionaries

3634import Language.PureScript.Types

3735

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

195193-- |

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

197195--

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

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

199197runCheck = runCheck' initEnvironment

200198

201199-- |

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

203201--

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

205−runCheck' env c = do

206− verbose <- asks optionsVerboseErrors

207− interpretMultipleErrors verbose $ do

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

209− return (a, checkEnv s)

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

203+runCheck' env c = interpretMultipleErrors $ do

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

205+ return (a, checkEnv s)

210206

211207-- |

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

tests/Main.hs+8−8

@@ -35,21 +35,21 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do

3535 text <- readFile inputFile

3636 return (inputFile, text)

3737

38−loadPrelude :: Either String (String, String, P.Environment)

38+loadPrelude :: Either P.MultipleErrors (String, String, P.Environment)

3939loadPrelude =

4040 case P.parseModulesFromFiles id [("", P.prelude)] of

41− Left parseError -> Left (show parseError)

41+ Left parseError -> Left . P.errorMessage . P.ErrorParsingPrelude $ parseError

4242 Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }

4343

44−compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))

44+compile :: P.Options P.Compile -> [FilePath] -> IO (Either P.MultipleErrors (String, String, P.Environment))

4545compile opts inputFiles = do

4646 modules <- P.parseModulesFromFiles id <$> readInput inputFiles

4747 case modules of

4848 Left parseError ->

49− return (Left $ show parseError)

49+ return . Left . P.errorMessage . P.ErrorParsingPrelude $ parseError

5050 Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts

5151

52−assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()

52+assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either P.MultipleErrors (String, String, P.Environment) -> IO (Maybe String)) -> IO ()

5353assert preludeExterns opts inputFile f = do

5454 e <- compile opts [preludeExterns, inputFile]

5555 maybeErr <- f e

@@ -64,7 +64,7 @@ assertCompiles preludeJs preludeExterns inputFile = do

6464 { P.optionsMain = Just "Main"

6565 , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]

6666 }

67− assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do

67+ assert preludeExterns options inputFile $ either (return . Just . P.prettyPrintMultipleErrors False) $ \(js, _, _) -> do

6868 process <- findNodeProcess

6969 result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process

7070 case result of

@@ -77,7 +77,7 @@ assertDoesNotCompile preludeExterns inputFile = do

7777 putStrLn $ "Assert " ++ inputFile ++ " does not compile"

7878 assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e ->

7979 case e of

80− Left err -> putStrLn err >> return Nothing

80+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing

8181 Right _ -> return $ Just "Should not have compiled"

8282

8383findNodeProcess :: IO (Maybe String)

@@ -88,7 +88,7 @@ main :: IO ()

8888main = do

8989 putStrLn "Compiling Prelude"

9090 case loadPrelude of

91− Left err -> putStrLn err >> exitFailure

91+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

9292 Right (preludeJs, exts, _) -> do

9393 tmp <- getTemporaryDirectory

9494 let preludeExterns = tmp ++ pathSeparator : "prelude.externs"