7b5ab61 · rowtype-yoga/purescript-native

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

Support multiple parse errors

commit7b5ab61306f23325da9178416fed726c1666307f authorGary Burgess <gary.burgess@gmail.com> dateMon 4 May 2015, 14:12 (11 years ago) parent680aff5

8 files changed+72−55

compare with golang

unifiedsplit

hierarchy/Main.hs+3−6 psc/Foreign.hs+8−5 psc/Main.hs+12−10 psci/PSCi.hs+2−4 src/Language/PureScript.hs+6−1 src/Language/PureScript/Docs/ParseAndDesugar.hs+1−2 src/Language/PureScript/Errors.hs+20−13 src/Language/PureScript/Parser/Declarations.hs+20−14

hierarchy/Main.hs+3−6

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

2727import System.Exit (exitFailure, exitSuccess)

2828import System.IO (hPutStr, stderr)

2929

30−import Text.Parsec as Par (ParseError)

31−

3230import qualified Language.PureScript as P

3331import qualified Paths_purescript as Paths

3432

35−

3633data HierarchyOptions = HierarchyOptions

3734 { hierachyInput :: FilePath

3835 , hierarchyOutput :: Maybe FilePath

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

5350runModuleName :: P.ModuleName -> String

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

5552

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

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

5754readInput filename = do

5855 content <- readFile filename

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

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

6057

6158compile :: HierarchyOptions -> IO ()

6259compile (HierarchyOptions input mOutput) = do

6360 modules <- readInput input

6461 case modules of

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

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

6663 Right ms -> do

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

6865 let name = runModuleName moduleName

psc/Foreign.hs+8−5

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

1212--

1313-----------------------------------------------------------------------------

1414

15+{-# LANGUAGE FlexibleContexts #-}

16+

1517module Foreign (parseForeignModulesFromFiles) where

1618

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

18−import Control.Monad (forM, msum)

20+import Control.Monad (msum)

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

1922import qualified Data.Map as M

2023import qualified Language.PureScript as P

2124import qualified Text.Parsec as PS

2225

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)

2427parseForeignModulesFromFiles files = do

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

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

2629 case findModuleName (lines file) of

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

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

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

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

2932 return $ M.fromList foreigns

3033

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

psc/Main.hs+12−10

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

4545import qualified Language.PureScript.CoreFn as CF

4646import qualified Paths_purescript as Paths

4747

48−

4948import Foreign

5049

5150data PSCOptions = PSCOptions

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

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

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

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

82− case parseInputs moduleFiles foreignFiles of

83− Left err -> do

84− hPutStrLn stderr err

81+ case runWriterT (parseInputs moduleFiles foreignFiles) of

82+ Left errs -> do

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

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

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

8889 Left errs -> do

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

9091 exitFailure

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

92− when (P.nonEmpty warnings) $

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

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

93+ when (P.nonEmpty warnings') $

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

9495 case output of

9596 Just path -> mkdirp path >> writeFile path js

9697 Nothing -> putStrLn js

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

99100 Nothing -> return ()

100101 exitSuccess

101102

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

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

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

103105parseInputs modules foreigns =

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

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

105107 <*> parseForeignModulesFromFiles foreigns

106108

107109compileJS :: 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)

4848import System.IO.Error (tryIOError)

4949import System.Process (readProcessWithExitCode)

5050

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

52−

5351import qualified Language.PureScript as P

5452import qualified Language.PureScript.Names as N

5553import qualified Paths_purescript as Paths

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

125123-- |

126124-- Load all modules, including the Prelude

127125--

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

129127loadAllModules files = do

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

131129 content <- readFile filename

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

140138 files <- PSCI . lift $ fmap psciImportedFilenames get

141139 modulesOrFirstError <- psciIO $ loadAllModules files

142140 case modulesOrFirstError of

143− Left err -> psciIO $ print err

141+ Left errs -> printErrors errs

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

145143

146144-- |

src/Language/PureScript.hs+6−1

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

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

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

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

232232 case externsModules of

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

234234 _ -> 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

235240

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

237242checkPreludeIsDefined ms = do

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

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

1616

1717import Web.Bower.PackageMeta (PackageName)

1818

19−import qualified Text.Parsec as Parsec

2019import qualified Language.PureScript as P

2120import qualified Language.PureScript.Constants as C

2221import Language.PureScript.Docs.Types

2322import Language.PureScript.Docs.Render

2423

2524data ParseDesugarError

26− = ParseError Parsec.ParseError

25+ = ParseError P.MultipleErrors

2726 | SortModulesError P.MultipleErrors

2827 | DesugarError P.MultipleErrors

2928 deriving (Show)

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

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

5151--

5252data SimpleErrorMessage

5353 = ErrorParsingExterns P.ParseError

54+ | ErrorParsingFFIModule FilePath

5455 | ErrorParsingPrelude P.ParseError

56+ | ErrorParsingModule P.ParseError

5557 | InvalidExternsFile FilePath

5658 | CannotGetFileInfo FilePath

5759 | CannotReadFile FilePath

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

121123-- |

122124-- Wrapper of simpler errors

123125--

124−data ErrorMessage

126+data ErrorMessage

125127 = NotYetDefined [Ident] ErrorMessage

126128 | ErrorUnifyingTypes Type Type ErrorMessage

127129 | ErrorInExpression Expr ErrorMessage

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

142144 | PositionedError SourceSpan ErrorMessage

143145 | SimpleErrorWrapper SimpleErrorMessage

144146 deriving (Show)

145−

147+

146148instance UnificationError Type ErrorMessage where

147149 occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t

148−

150+

149151instance UnificationError Kind ErrorMessage where

150152 occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k

151153

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

155157errorCode :: ErrorMessage -> String

156158errorCode em = case unwrapErrorMessage em of

157159 (ErrorParsingExterns _) -> "ErrorParsingExterns"

160+ (ErrorParsingFFIModule _) -> "ErrorParsingFFIModule"

158161 (ErrorParsingPrelude _) -> "ErrorParsingPrelude"

162+ (ErrorParsingModule _) -> "ErrorParsingModule"

159163 (InvalidExternsFile _) -> "InvalidExternsFile"

160164 (CannotGetFileInfo _) -> "CannotGetFileInfo"

161165 (CannotReadFile _) -> "CannotReadFile"

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

224228-- |

225229-- A stack trace for an error

226230--

227−newtype MultipleErrors = MultipleErrors

231+newtype MultipleErrors = MultipleErrors

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

229−

233+

230234instance UnificationError Type MultipleErrors where

231235 occursCheckFailed = occursCheckFailed

232−

236+

233237instance UnificationError Kind MultipleErrors where

234238 occursCheckFailed = occursCheckFailed

235239

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

288292 (SimpleErrorWrapper sem) -> sem

289293

290294replaceUnknowns :: Type -> State UnknownMap Type

291−replaceUnknowns = everywhereOnTypesM replaceTypes

295+replaceUnknowns = everywhereOnTypesM replaceTypes

292296 where

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

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

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

348352 where

349353 wikiUri :: String

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

351−

355+

352356 go :: ErrorMessage -> Box.Box

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

354358 , indent . line $ path

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

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

363367 , indent . line . show $ err

364368 ]

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

370+ , indent . line $ path

371+ ]

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

366373 , indent . line . show $ err

367374 ]

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

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

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

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

412− , indent $ line $ prettyPrintValue expr

419+ , indent $ line $ prettyPrintValue expr

413420 ]) binding

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

415422 , indent $ line $ prettyPrintType t1

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

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

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

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

435− , indent $ line $ prettyPrintValue expr'

442+ , indent $ line $ prettyPrintValue expr'

436443 ]) expr

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

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

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

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

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

465472 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."

467474 ]

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

469476 , indent $ go err

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

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

571578 , indent $ prettyPrintDictionaryValue sup

572579 ]

573−

580+

574581 -- |

575582 -- Pretty print and export declaration

576− --

583+ --

577584 prettyPrintExport :: DeclarationRef -> String

578585 prettyPrintExport (TypeRef pn _) = show pn

579586 prettyPrintExport (ValueRef ident) = show ident

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

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

1313--

1414-----------------------------------------------------------------------------

1515

16+{-# LANGUAGE FlexibleContexts #-}

17+{-# LANGUAGE ScopedTypeVariables #-}

1618{-# LANGUAGE TupleSections #-}

1719

1820module Language.PureScript.Parser.Declarations (

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

3133import Prelude hiding (lex)

3234

3335import Data.Maybe (fromMaybe)

34−import Data.Traversable (forM)

3536

3637import Control.Applicative

3738import Control.Arrow ((+++))

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

3840

3941import Language.PureScript.AST

4042import Language.PureScript.Comments

4143import Language.PureScript.Environment

44+import Language.PureScript.Errors

4245import Language.PureScript.Kinds

4346import Language.PureScript.Names

4447import Language.PureScript.Parser.Common

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

117120 <|> (do reserved "instance"

118121 name <- parseIdent <* indented <* doubleColon

119122 deps <- P.option [] $ do

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

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

121124 indented

122125 rfatArrow

123− return deps

126+ return deps'

124127 className <- indented *> parseQualified properName

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

126129 return $ ExternInstanceDeclaration name deps className tys)

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

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

150153 return $ ImportDeclaration mn declType asQ

151154

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

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

153156parseImportDeclaration' = do

154157 reserved "import"

155158 indented

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

175178 asQ <- moduleName

176179 return (moduleName', declType, Just asQ)

177180 importDeclarationType expectedType = do

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

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

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

180183

181184

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

211214 rfatArrow

212215 return deps

213216 className <- indented *> parseQualified properName

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

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

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

216219 indented *> reserved "where"

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

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

219222

220223positioned :: TokenParser Declaration -> TokenParser Declaration

221−positioned d = withSourceSpan PositionedDeclaration d

224+positioned = withSourceSpan PositionedDeclaration

222225

223226-- |

224227-- Parse a single declaration

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

259262-- |

260263-- Parse a collection of modules

261264--

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

263−parseModulesFromFiles toFilePath input =

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

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

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

267+parseModulesFromFiles toFilePath input = do

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

265269 let filename = toFilePath k

266− ts <- lex filename content

267− ms <- runTokenParser filename parseModules ts

270+ ts <- wrapError $ lex filename content

271+ ms <- wrapError $ runTokenParser filename parseModules ts

268272 return (k, ms)

273+ return $ collect modules

269274 where

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

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

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

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

272279

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

525532 , parseObjectBinder

526533 , parseArrayBinder

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

535+

528536-- |

529537-- Parse a guard

530538--

531539parseGuard :: TokenParser Guard

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

533−

534−