7b5ab61 · rowtype-yoga/purescript-native

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

on golang help sign in

Support multiple parse errors

7b5ab61Gary Burgess11 years ago

hierarchy/Main.hs+3−6

compare with golang

unifiedsplit

@@ -27,12 +27,9 @@ import System.FilePath ((</>))

27import System.Exit (exitFailure, exitSuccess)

28import System.IO (hPutStr, stderr)

30−import Text.Parsec as Par (ParseError)

31−

32import qualified Language.PureScript as P

30import qualified Language.PureScript as P

33import qualified Paths_purescript as Paths

31import qualified Paths_purescript as Paths

35−

36data HierarchyOptions = HierarchyOptions

33data HierarchyOptions = HierarchyOptions

37 { hierachyInput :: FilePath

34 { hierachyInput :: FilePath

38 , hierarchyOutput :: Maybe FilePath

35 , hierarchyOutput :: Maybe FilePath

@@ -53,16 +50,16 @@ instance Ord SuperMap where

53runModuleName :: P.ModuleName -> String

50runModuleName :: P.ModuleName -> String

54runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)

51runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)

56−readInput :: FilePath -> IO (Either Par.ParseError [P.Module])

53+readInput :: FilePath -> IO (Either P.MultipleErrors [P.Module])

57readInput filename = do

54readInput filename = do

58 content <- readFile filename

55 content <- readFile filename

59− return $ fmap (map snd) $ P.parseModulesFromFiles id [(filename, content)]

56+ return $ map snd <$> P.parseModulesFromFiles id [(filename, content)]

61compile :: HierarchyOptions -> IO ()

58compile :: HierarchyOptions -> IO ()

62compile (HierarchyOptions input mOutput) = do

59compile (HierarchyOptions input mOutput) = do

63 modules <- readInput input

60 modules <- readInput input

64 case modules of

61 case modules of

65− Left err -> hPutStr stderr (show err) >> exitFailure

62+ Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors False errs) >> exitFailure

66 Right ms -> do

63 Right ms -> do

67 for_ ms $ \(P.Module _ moduleName decls _) ->

64 for_ ms $ \(P.Module _ moduleName decls _) ->

68 let name = runModuleName moduleName

65 let name = runModuleName moduleName

psc/Foreign.hs+8−5

@@ -12,20 +12,23 @@

12--

13-----------------------------------------------------------------------------

15+{-# LANGUAGE FlexibleContexts #-}

16+

15module Foreign (parseForeignModulesFromFiles) where

17module Foreign (parseForeignModulesFromFiles) where

17import Control.Applicative ((*>), (<*))

19import Control.Applicative ((*>), (<*))

18−import Control.Monad (forM, msum)

20+import Control.Monad (msum)

21+import Control.Monad.Error.Class (MonadError(..))

19import qualified Data.Map as M

22import qualified Data.Map as M

20import qualified Language.PureScript as P

23import qualified Language.PureScript as P

21import qualified Text.Parsec as PS

24import qualified Text.Parsec as PS

23−parseForeignModulesFromFiles :: [(FilePath, String)] -> Either String (M.Map P.ModuleName String)

26+parseForeignModulesFromFiles :: (MonadError P.MultipleErrors m, Functor m) => [(FilePath, String)] -> m (M.Map P.ModuleName String)

24parseForeignModulesFromFiles files = do

27parseForeignModulesFromFiles files = do

25− foreigns <- forM files $ \(path, file) -> do

28+ foreigns <- P.parU files $ \(path, file) ->

26 case findModuleName (lines file) of

29 case findModuleName (lines file) of

27− Just name -> Right (name, file)

30+ Just name -> return (name, file)

28− Nothing -> Left $ "Could not find a module definition comment in " ++ path

31+ Nothing -> throwError (P.errorMessage $ P.ErrorParsingFFIModule path)

29 return $ M.fromList foreigns

32 return $ M.fromList foreigns

31findModuleName :: [String] -> Maybe P.ModuleName

34findModuleName :: [String] -> Maybe P.ModuleName

psc/Main.hs+12−10

@@ -45,7 +45,6 @@ import qualified Language.PureScript.Constants as C

45import qualified Language.PureScript.CoreFn as CF

46import qualified Paths_purescript as Paths

48−

49import Foreign

48import Foreign

51data PSCOptions = PSCOptions

50data PSCOptions = PSCOptions

@@ -79,18 +78,20 @@ compile (PSCOptions input inputForeign opts stdin output externs usePrefix) = do

79 let prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

78 let prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

80 moduleFiles <- readInput (InputOptions (P.optionsNoPrelude opts) stdin input)

79 moduleFiles <- readInput (InputOptions (P.optionsNoPrelude opts) stdin input)

81 foreignFiles <- forM inputForeign (\inFile -> (inFile,) <$> readFile inFile)

80 foreignFiles <- forM inputForeign (\inFile -> (inFile,) <$> readFile inFile)

82− case parseInputs moduleFiles foreignFiles of

81+ case runWriterT (parseInputs moduleFiles foreignFiles) of

83− Left err -> do

82+ Left errs -> do

84− hPutStrLn stderr err

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

85 exitFailure

84 exitFailure

86− Right (ms, foreigns) ->

85+ Right ((ms, foreigns), warnings) -> do

86+ when (P.nonEmpty warnings) $

87+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

87 case runPSC opts (compileJS (map snd ms) foreigns prefix) of

88 case runPSC opts (compileJS (map snd ms) foreigns prefix) of

88 Left errs -> do

89 Left errs -> do

89 hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

90 hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

90 exitFailure

91 exitFailure

91− Right ((js, exts), warnings) -> do

92+ Right ((js, exts), warnings') -> do

92− when (P.nonEmpty warnings) $

93+ when (P.nonEmpty warnings') $

93− hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

94+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')

94 case output of

95 case output of

95 Just path -> mkdirp path >> writeFile path js

96 Just path -> mkdirp path >> writeFile path js

96 Nothing -> putStrLn js

97 Nothing -> putStrLn js

@@ -99,9 +100,10 @@ compile (PSCOptions input inputForeign opts stdin output externs usePrefix) = do

99 Nothing -> return ()

100 Nothing -> return ()

100 exitSuccess

101 exitSuccess

101

102

103+parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)

102−parseInputs :: [(Maybe FilePath, String)] -> [(FilePath, String)] -> Either String ([(Maybe FilePath, P.Module)], M.Map P.ModuleName String)

104+ => [(Maybe FilePath, String)] -> [(FilePath, String)] -> m ([(Maybe FilePath, P.Module)], M.Map P.ModuleName String)

103parseInputs modules foreigns =

105parseInputs modules foreigns =

104− (,) <$> either (Left . show) Right (P.parseModulesFromFiles (fromMaybe "") modules)

106+ (,) <$> P.parseModulesFromFiles (fromMaybe "") modules

105 <*> parseForeignModulesFromFiles foreigns

107 <*> parseForeignModulesFromFiles foreigns

106

108

107compileJS :: forall m. (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m, MonadReader (P.Options P.Compile) m)

109compileJS :: forall m. (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m, MonadReader (P.Options P.Compile) m)

psci/PSCi.hs+2−4

@@ -48,8 +48,6 @@ import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)

48import System.IO.Error (tryIOError)

49import System.Process (readProcessWithExitCode)

51−import qualified Text.Parsec as Par (ParseError)

52−

53import qualified Language.PureScript as P

51import qualified Language.PureScript as P

54import qualified Language.PureScript.Names as N

52import qualified Language.PureScript.Names as N

55import qualified Paths_purescript as Paths

53import qualified Paths_purescript as Paths

@@ -125,7 +123,7 @@ loadModule filename = do

125-- |

123-- |

126-- Load all modules, including the Prelude

124-- Load all modules, including the Prelude

127--

125--

128−loadAllModules :: [FilePath] -> IO (Either Par.ParseError [(Either P.RebuildPolicy FilePath, P.Module)])

126+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(Either P.RebuildPolicy FilePath, P.Module)])

129loadAllModules files = do

127loadAllModules files = do

130 filesAndContent <- forM files $ \filename -> do

128 filesAndContent <- forM files $ \filename -> do

131 content <- readFile filename

129 content <- readFile filename

@@ -140,7 +138,7 @@ loadAllImportedModules = do

140 files <- PSCI . lift $ fmap psciImportedFilenames get

138 files <- PSCI . lift $ fmap psciImportedFilenames get

141 modulesOrFirstError <- psciIO $ loadAllModules files

139 modulesOrFirstError <- psciIO $ loadAllModules files

142 case modulesOrFirstError of

140 case modulesOrFirstError of

143− Left err -> psciIO $ print err

141+ Left errs -> printErrors errs

144 Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }

142 Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }

145

143

146-- |

144-- |

src/Language/PureScript.hs+6−1

@@ -228,10 +228,15 @@ make outputDir ms prefix = do

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

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

230 externs <- readTextFile externsFile

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

231+ externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(externsFile, externs)]

232 case externsModules of

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

234 _ -> throwError . errorMessage . InvalidExternsFile $ externsFile

235+ where

236+ alterErrors = flip catchError $ \(MultipleErrors errs) ->

237+ throwError . MultipleErrors $ flip map errs $ \e -> case e of

238+ SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)

239+ _ -> e

235

240

236checkPreludeIsDefined :: (MonadWriter MultipleErrors m) => [Module] -> m ()

241checkPreludeIsDefined :: (MonadWriter MultipleErrors m) => [Module] -> m ()

237checkPreludeIsDefined ms = do

242checkPreludeIsDefined ms = do

src/Language/PureScript/Docs/ParseAndDesugar.hs+1−2

@@ -16,14 +16,13 @@ import Control.Monad.IO.Class (MonadIO(..))

17import Web.Bower.PackageMeta (PackageName)

19−import qualified Text.Parsec as Parsec

20import qualified Language.PureScript as P

19import qualified Language.PureScript as P

21import qualified Language.PureScript.Constants as C

20import qualified Language.PureScript.Constants as C

22import Language.PureScript.Docs.Types

21import Language.PureScript.Docs.Types

23import Language.PureScript.Docs.Render

22import Language.PureScript.Docs.Render

25data ParseDesugarError

24data ParseDesugarError

26− = ParseError Parsec.ParseError

25+ = ParseError P.MultipleErrors

27 | SortModulesError P.MultipleErrors

26 | SortModulesError P.MultipleErrors

28 | DesugarError P.MultipleErrors

27 | DesugarError P.MultipleErrors

29 deriving (Show)

28 deriving (Show)

src/Language/PureScript/Errors.hs+20−13

@@ -51,7 +51,9 @@ import qualified Text.Parsec as P

51--

52data SimpleErrorMessage

53 = ErrorParsingExterns P.ParseError

54+ | ErrorParsingFFIModule FilePath

54 | ErrorParsingPrelude P.ParseError

55 | ErrorParsingPrelude P.ParseError

56+ | ErrorParsingModule P.ParseError

55 | InvalidExternsFile FilePath

57 | InvalidExternsFile FilePath

56 | CannotGetFileInfo FilePath

58 | CannotGetFileInfo FilePath

57 | CannotReadFile FilePath

59 | CannotReadFile FilePath

@@ -121,7 +123,7 @@ data SimpleErrorMessage

121-- |

123-- |

122-- Wrapper of simpler errors

124-- Wrapper of simpler errors

123--

125--

124−data ErrorMessage

126+data ErrorMessage

125 = NotYetDefined [Ident] ErrorMessage

127 = NotYetDefined [Ident] ErrorMessage

126 | ErrorUnifyingTypes Type Type ErrorMessage

128 | ErrorUnifyingTypes Type Type ErrorMessage

127 | ErrorInExpression Expr ErrorMessage

129 | ErrorInExpression Expr ErrorMessage

@@ -142,10 +144,10 @@ data ErrorMessage

142 | PositionedError SourceSpan ErrorMessage

144 | PositionedError SourceSpan ErrorMessage

143 | SimpleErrorWrapper SimpleErrorMessage

145 | SimpleErrorWrapper SimpleErrorMessage

144 deriving (Show)

146 deriving (Show)

145−

147+

146instance UnificationError Type ErrorMessage where

148instance UnificationError Type ErrorMessage where

147 occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t

149 occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t

148−

150+

149instance UnificationError Kind ErrorMessage where

151instance UnificationError Kind ErrorMessage where

150 occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k

152 occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k

151

153

@@ -155,7 +157,9 @@ instance UnificationError Kind ErrorMessage where

155errorCode :: ErrorMessage -> String

157errorCode :: ErrorMessage -> String

156errorCode em = case unwrapErrorMessage em of

158errorCode em = case unwrapErrorMessage em of

157 (ErrorParsingExterns _) -> "ErrorParsingExterns"

159 (ErrorParsingExterns _) -> "ErrorParsingExterns"

160+ (ErrorParsingFFIModule _) -> "ErrorParsingFFIModule"

158 (ErrorParsingPrelude _) -> "ErrorParsingPrelude"

161 (ErrorParsingPrelude _) -> "ErrorParsingPrelude"

162+ (ErrorParsingModule _) -> "ErrorParsingModule"

159 (InvalidExternsFile _) -> "InvalidExternsFile"

163 (InvalidExternsFile _) -> "InvalidExternsFile"

160 (CannotGetFileInfo _) -> "CannotGetFileInfo"

164 (CannotGetFileInfo _) -> "CannotGetFileInfo"

161 (CannotReadFile _) -> "CannotReadFile"

165 (CannotReadFile _) -> "CannotReadFile"

@@ -224,12 +228,12 @@ errorCode em = case unwrapErrorMessage em of

224-- |

228-- |

225-- A stack trace for an error

229-- A stack trace for an error

226--

230--

227−newtype MultipleErrors = MultipleErrors

231+newtype MultipleErrors = MultipleErrors

228 { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)

232 { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)

229−

233+

230instance UnificationError Type MultipleErrors where

234instance UnificationError Type MultipleErrors where

231 occursCheckFailed = occursCheckFailed

235 occursCheckFailed = occursCheckFailed

232−

236+

233instance UnificationError Kind MultipleErrors where

237instance UnificationError Kind MultipleErrors where

234 occursCheckFailed = occursCheckFailed

238 occursCheckFailed = occursCheckFailed

235

239

@@ -288,7 +292,7 @@ unwrapErrorMessage em = case em of

288 (SimpleErrorWrapper sem) -> sem

292 (SimpleErrorWrapper sem) -> sem

289

293

290replaceUnknowns :: Type -> State UnknownMap Type

294replaceUnknowns :: Type -> State UnknownMap Type

291−replaceUnknowns = everywhereOnTypesM replaceTypes

295+replaceUnknowns = everywhereOnTypesM replaceTypes

292 where

296 where

293 lookupTable :: (LabelType, Unknown) -> UnknownMap -> (Unknown, UnknownMap)

297 lookupTable :: (LabelType, Unknown) -> UnknownMap -> (Unknown, UnknownMap)

294 lookupTable x m = case M.lookup x m of

298 lookupTable x m = case M.lookup x m of

@@ -348,7 +352,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag

348 where

352 where

349 wikiUri :: String

353 wikiUri :: String

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

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

351−

355+

352 go :: ErrorMessage -> Box.Box

356 go :: ErrorMessage -> Box.Box

353 goSimple (CannotGetFileInfo path) = paras [ line "Unable to read file info: "

357 goSimple (CannotGetFileInfo path) = paras [ line "Unable to read file info: "

354 , indent . line $ path

358 , indent . line $ path

@@ -362,6 +366,9 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag

362 goSimple (ErrorParsingExterns err) = paras [ line "Error parsing externs files: "

366 goSimple (ErrorParsingExterns err) = paras [ line "Error parsing externs files: "

363 , indent . line . show $ err

367 , indent . line . show $ err

364 ]

368 ]

369+ goSimple (ErrorParsingFFIModule path) = paras [ line "Unable to parse module from FFI file: "

370+ , indent . line $ path

371+ ]

365 goSimple (ErrorParsingPrelude err) = paras [ line "Error parsing prelude: "

372 goSimple (ErrorParsingPrelude err) = paras [ line "Error parsing prelude: "

366 , indent . line . show $ err

373 , indent . line . show $ err

367 ]

374 ]

@@ -409,7 +416,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag

409 goSimple (PartiallyAppliedSynonym name) = line $ "Partially applied type synonym " ++ show name

416 goSimple (PartiallyAppliedSynonym name) = line $ "Partially applied type synonym " ++ show name

410 goSimple (EscapedSkolem binding) = paras $ [ line "Rigid/skolem type variable has escaped." ]

417 goSimple (EscapedSkolem binding) = paras $ [ line "Rigid/skolem type variable has escaped." ]

411 <> foldMap (\expr -> [ line "Relevant expression: "

418 <> foldMap (\expr -> [ line "Relevant expression: "

412− , indent $ line $ prettyPrintValue expr

419+ , indent $ line $ prettyPrintValue expr

413 ]) binding

420 ]) binding

414 goSimple (TypesDoNotUnify t1 t2) = paras [ line "Cannot unify type"

421 goSimple (TypesDoNotUnify t1 t2) = paras [ line "Cannot unify type"

415 , indent $ line $ prettyPrintType t1

422 , indent $ line $ prettyPrintType t1

@@ -432,7 +439,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag

432 goSimple (NoInstanceFound nm ts) = line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)

439 goSimple (NoInstanceFound nm ts) = line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)

433 goSimple (DuplicateLabel l expr) = paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]

440 goSimple (DuplicateLabel l expr) = paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]

434 <> foldMap (\expr' -> [ line "Relevant expression: "

441 <> foldMap (\expr' -> [ line "Relevant expression: "

435− , indent $ line $ prettyPrintValue expr'

442+ , indent $ line $ prettyPrintValue expr'

436 ]) expr

443 ]) expr

437 goSimple (DuplicateTypeArgument name) = line $ "Duplicate type argument " ++ show name

444 goSimple (DuplicateTypeArgument name) = line $ "Duplicate type argument " ++ show name

438 goSimple (DuplicateValueDeclaration nm) = line $ "Duplicate value declaration for " ++ show nm

445 goSimple (DuplicateValueDeclaration nm) = line $ "Duplicate value declaration for " ++ show nm

@@ -463,7 +470,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag

463 goSimple (ShadowedName nm) = line $ "Name '" ++ show nm ++ "' was shadowed."

470 goSimple (ShadowedName nm) = line $ "Name '" ++ show nm ++ "' was shadowed."

464 goSimple (WildcardInferredType ty) = line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty

471 goSimple (WildcardInferredType ty) = line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty

465 goSimple PreludeNotPresent = paras [ line $ "There is no Prelude module loaded, and the --no-prelude option was not specified."

472 goSimple PreludeNotPresent = paras [ line $ "There is no Prelude module loaded, and the --no-prelude option was not specified."

466− , line $ "You probably need to install the Prelude and other dependencies using Bower."

473+ , line $ "You probably need to install the Prelude and other dependencies using Bower."

467 ]

474 ]

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

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

469 , indent $ go err

476 , indent $ go err

@@ -570,10 +577,10 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag

570 prettyPrintDictionaryValue (SubclassDictionaryValue sup nm _) = paras [ line $ (show nm) ++ " via superclass"

577 prettyPrintDictionaryValue (SubclassDictionaryValue sup nm _) = paras [ line $ (show nm) ++ " via superclass"

571 , indent $ prettyPrintDictionaryValue sup

578 , indent $ prettyPrintDictionaryValue sup

572 ]

579 ]

573−

580+

574 -- |

581 -- |

575 -- Pretty print and export declaration

582 -- Pretty print and export declaration

576− --

583+ --

577 prettyPrintExport :: DeclarationRef -> String

584 prettyPrintExport :: DeclarationRef -> String

578 prettyPrintExport (TypeRef pn _) = show pn

585 prettyPrintExport (TypeRef pn _) = show pn

579 prettyPrintExport (ValueRef ident) = show ident

586 prettyPrintExport (ValueRef ident) = show ident

src/Language/PureScript/Parser/Declarations.hs+20−14

@@ -13,6 +13,8 @@

13--

14-----------------------------------------------------------------------------

16+{-# LANGUAGE FlexibleContexts #-}

17+{-# LANGUAGE ScopedTypeVariables #-}

16{-# LANGUAGE TupleSections #-}

18{-# LANGUAGE TupleSections #-}

18module Language.PureScript.Parser.Declarations (

20module Language.PureScript.Parser.Declarations (

@@ -31,14 +33,15 @@ module Language.PureScript.Parser.Declarations (

31import Prelude hiding (lex)

33import Prelude hiding (lex)

33import Data.Maybe (fromMaybe)

35import Data.Maybe (fromMaybe)

34−import Data.Traversable (forM)

36import Control.Applicative

37import Control.Applicative

37import Control.Arrow ((+++))

38import Control.Arrow ((+++))

39+import Control.Monad.Error.Class (MonadError(..))

39import Language.PureScript.AST

41import Language.PureScript.AST

40import Language.PureScript.Comments

42import Language.PureScript.Comments

41import Language.PureScript.Environment

43import Language.PureScript.Environment

44+import Language.PureScript.Errors

42import Language.PureScript.Kinds

45import Language.PureScript.Kinds

43import Language.PureScript.Names

46import Language.PureScript.Names

44import Language.PureScript.Parser.Common

47import Language.PureScript.Parser.Common

@@ -117,10 +120,10 @@ parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "imp

117 <|> (do reserved "instance"

120 <|> (do reserved "instance"

118 name <- parseIdent <* indented <* doubleColon

121 name <- parseIdent <* indented <* doubleColon

119 deps <- P.option [] $ do

122 deps <- P.option [] $ do

120− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

123+ deps' <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

121 indented

124 indented

122 rfatArrow

125 rfatArrow

123− return deps

126+ return deps'

124 className <- indented *> parseQualified properName

127 className <- indented *> parseQualified properName

125 tys <- P.many (indented *> noWildcards parseTypeAtom)

128 tys <- P.many (indented *> noWildcards parseTypeAtom)

126 return $ ExternInstanceDeclaration name deps className tys)

129 return $ ExternInstanceDeclaration name deps className tys)

@@ -149,7 +152,7 @@ parseImportDeclaration = do

149 (mn, declType, asQ) <- parseImportDeclaration'

152 (mn, declType, asQ) <- parseImportDeclaration'

150 return $ ImportDeclaration mn declType asQ

153 return $ ImportDeclaration mn declType asQ

151

154

152−parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, (Maybe ModuleName))

155+parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName)

153parseImportDeclaration' = do

156parseImportDeclaration' = do

154 reserved "import"

157 reserved "import"

155 indented

158 indented

@@ -175,7 +178,7 @@ parseImportDeclaration' = do

175 asQ <- moduleName

178 asQ <- moduleName

176 return (moduleName', declType, Just asQ)

179 return (moduleName', declType, Just asQ)

177 importDeclarationType expectedType = do

180 importDeclarationType expectedType = do

178− idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)

181+ idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef)

179 return $ fromMaybe Implicit (expectedType <$> idents)

182 return $ fromMaybe Implicit (expectedType <$> idents)

180

183

181

184

@@ -211,14 +214,14 @@ parseTypeInstanceDeclaration = do

211 rfatArrow

214 rfatArrow

212 return deps

215 return deps

213 className <- indented *> parseQualified properName

216 className <- indented *> parseQualified properName

214− ty <- P.many (indented *> (noWildcards parseTypeAtom))

217+ ty <- P.many (indented *> noWildcards parseTypeAtom)

215 members <- P.option [] . P.try $ do

218 members <- P.option [] . P.try $ do

216 indented *> reserved "where"

219 indented *> reserved "where"

217 mark (P.many (same *> positioned parseValueDeclaration))

220 mark (P.many (same *> positioned parseValueDeclaration))

218 return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members

221 return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members

219

222

220positioned :: TokenParser Declaration -> TokenParser Declaration

223positioned :: TokenParser Declaration -> TokenParser Declaration

221−positioned d = withSourceSpan PositionedDeclaration d

224+positioned = withSourceSpan PositionedDeclaration

222

225

223-- |

226-- |

224-- Parse a single declaration

227-- Parse a single declaration

@@ -259,14 +262,18 @@ parseModule = do

259-- |

262-- |

260-- Parse a collection of modules

263-- Parse a collection of modules

261--

264--

265+parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) =>

262−parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)]

266+ (k -> String) -> [(k, String)] -> m [(k, Module)]

263−parseModulesFromFiles toFilePath input =

267+parseModulesFromFiles toFilePath input = do

264− fmap collect . forM input $ \(k, content) -> do

268+ modules <- parU input $ \(k, content) -> do

265 let filename = toFilePath k

269 let filename = toFilePath k

266− ts <- lex filename content

270+ ts <- wrapError $ lex filename content

267− ms <- runTokenParser filename parseModules ts

271+ ms <- wrapError $ runTokenParser filename parseModules ts

268 return (k, ms)

272 return (k, ms)

273+ return $ collect modules

269 where

274 where

275+ wrapError :: Either P.ParseError a -> m a

276+ wrapError = either (throwError . errorMessage . ErrorParsingModule) return

270 collect :: [(k, [v])] -> [(k, v)]

277 collect :: [(k, [v])] -> [(k, v)]

271 collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]

278 collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]

272

279

@@ -525,10 +532,9 @@ parseBinderNoParens = P.choice (map P.try

525 , parseObjectBinder

532 , parseObjectBinder

526 , parseArrayBinder

533 , parseArrayBinder

527 , parens parseBinder ]) P.<?> "binder"

534 , parens parseBinder ]) P.<?> "binder"

535+

528-- |

536-- |

529-- Parse a guard

537-- Parse a guard

530--

538--

531parseGuard :: TokenParser Guard

539parseGuard :: TokenParser Guard

532parseGuard = pipe *> C.indented *> parseValue

540parseGuard = pipe *> C.indented *> parseValue

533−

534−