49fac78 · rowtype-yoga/purescript-native

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

Tidy up MonadError code a bit more

commit49fac7834e51780989dc9158f2668400d042e18b authorPhil Freeman <paf31@cantab.net> dateTue 24 Mar 2015, 18:07 (12 years ago) parent8f8615b

8 files changed+92−55

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+33−3 src/Language/PureScript/ModuleDependencies.hs+4−3 src/Language/PureScript/Sugar/CaseDeclarations.hs+1−1 src/Language/PureScript/TypeChecker/Monad.hs+5−9

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+33−3

@@ -36,11 +36,18 @@ 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+ | InvalidExternsFile FilePath

47+ | CannotGetFileInfo FilePath

48+ | CannotReadFile FilePath

49+ | CannotWriteFile FilePath

50+ | InfiniteType Type

4451 | InfiniteKind Kind

4552 | CannotReorderOperators

4653 | MultipleFixities Ident

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

7077 | InvalidDoLet

7178 | CycleInDeclaration Ident

7279 | CycleInTypeSynonym (Maybe ProperName)

80+ | CycleInModules [ModuleName]

7381 | NameIsUndefined Ident

7482 | NameNotInScope Ident

7583 | UndefinedTypeVariable ProperName

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

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

127135--

128136errorCode :: ErrorMessage -> String

137+errorCode (ErrorParsingExterns _) = "ErrorParsingExterns"

138+errorCode (InvalidExternsFile _) = "InvalidExternsFile"

139+errorCode (CannotGetFileInfo _) = "CannotGetFileInfo"

140+errorCode (CannotReadFile _) = "CannotReadFile"

141+errorCode (CannotWriteFile _) = "CannotWriteFile"

129142errorCode (InfiniteType _) = "InfiniteType"

130143errorCode (InfiniteKind _) = "InfiniteKind"

131144errorCode CannotReorderOperators = "CannotReorderOperators"

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

156169errorCode InvalidDoLet = "InvalidDoLet"

157170errorCode (CycleInDeclaration _) = "CycleInDeclaration"

158171errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"

172+errorCode (CycleInModules _) = "CycleInModules"

159173errorCode (NameIsUndefined _) = "NameIsUndefined"

160174errorCode (NameNotInScope _) = "NameNotInScope"

161175errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"

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

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

246260

247261 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+ ]

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

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

250279 go CannotReorderOperators = line "Unable to reorder operators"

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

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

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

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

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

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

282312 , indent $ go err

283313 ]

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

490520-- |

491521-- Interpret multiple errors in a monad supporting errors

492522--

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

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

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

524+interpretMultipleErrors = either throwError return

495525

496526-- |

497527-- 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