bbefa33 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Fixes for error formatting

bbefa33Jason Felice9 years ago

src/Idris/Parser/Helpers.hs+44−10

compare with master

unifiedsplit

@@ -26,26 +26,63 @@ import Control.Monad.State.Strict

26import Data.Char

27import qualified Data.HashSet as HS

28import Data.List

29+import Data.List.NonEmpty (NonEmpty(..))

30+import qualified Data.List.NonEmpty as NonEmpty

29import qualified Data.Map as M

31import qualified Data.Map as M

30import Data.Maybe

32import Data.Maybe

33+import qualified Data.Set as Set

31import qualified Data.Text as T

34import qualified Data.Text as T

32import System.FilePath

35import System.FilePath

33−import Data.List.NonEmpty (fromList)

34import qualified Text.Parser.Char

36import qualified Text.Parser.Char

35import qualified Text.Parser.Combinators

37import qualified Text.Parser.Combinators

36import qualified Text.Parser.Token as Tok

38import qualified Text.Parser.Token as Tok

39+import Text.PrettyPrint.ANSI.Leijen ((<>), (<+>))

37import qualified Text.PrettyPrint.ANSI.Leijen as PP

40import qualified Text.PrettyPrint.ANSI.Leijen as PP

38import Text.Megaparsec ((<?>))

41import Text.Megaparsec ((<?>))

39import qualified Text.Megaparsec as P

42import qualified Text.Megaparsec as P

40import qualified Text.Megaparsec.Char as P

43import qualified Text.Megaparsec.Char as P

41import qualified Text.Megaparsec.Char.Lexer as P hiding (space)

44import qualified Text.Megaparsec.Char.Lexer as P hiding (space)

43−newtype ParseError = ParseError { parseErrorDoc :: PP.Doc }

45-- | Idris parser with state used during parsing

47-- | Idris parser with state used during parsing

46type IdrisParser = StateT IState IdrisInnerParser

48type IdrisParser = StateT IState IdrisInnerParser

47type IdrisInnerParser = P.Parsec () String

49type IdrisInnerParser = P.Parsec () String

48type ParseState = P.State String

50type ParseState = P.State String

51+type ParseError = P.ParseError (P.Token String) ()

52+

53+parseErrorDoc :: ParseError -> PP.Doc

54+parseErrorDoc (P.TrivialError (pos :| _) un ex)

55+ = ppLocation pos <> PP.text ": error:" <+> ppCommas (ppUnexpected un ++ ppExpected ex)

56+ where

57+ ppCommas :: [PP.Doc] -> PP.Doc

58+ ppCommas = PP.sep . PP.punctuate (PP.char ',')

59+

60+ ppUnexpected :: Maybe (P.ErrorItem (P.Token String)) -> [PP.Doc]

61+ ppUnexpected Nothing = []

62+ ppUnexpected (Just item) = [PP.text "unexpected" <+> ppCommas (ppItem item)]

63+

64+ ppExpected :: Set.Set (P.ErrorItem (P.Token String)) -> [PP.Doc]

65+ ppExpected items

66+ | Set.null items = []

67+ | otherwise = [PP.text "expected" <+> ppCommas (join . map ppItem . Set.toList $ items)]

68+

69+ ppItem :: P.ErrorItem (P.Token String) -> [PP.Doc]

70+ ppItem (P.Tokens ts) = (PP.char '"' <>) . (<> PP.char '"') . PP.char <$> NonEmpty.toList ts

71+ ppItem (P.Label lbl) = [PP.text $ NonEmpty.toList lbl]

72+ ppItem P.EndOfInput = [PP.text "end of input"]

73+parseErrorDoc (P.FancyError (pos :| _) errs) = PP.vcat $ (ppError pos <+>) . ppErrorFancy <$> Set.toList errs

74+ where

75+ ppErrorFancy :: P.ErrorFancy e -> PP.Doc

76+ ppErrorFancy (P.ErrorFail msg) = PP.text msg

77+ ppErrorFancy (P.ErrorIndentation ord ref act) = undefined -- Not using megaparsec's indentation yet

78+ ppErrorFancy (P.ErrorCustom _) = undefined -- Not using custom errors yet

79+

80+ppLocation :: P.SourcePos -> PP.Doc

81+ppLocation (P.SourcePos name line col) =

82+ PP.text name <> PP.char ':' <> PP.int (P.unPos line) <> PP.char ':' <> PP.int (P.unPos col)

83+

84+ppError :: P.SourcePos -> PP.Doc

85+ppError pos = ppLocation pos <> PP.char ':' <+> PP.text "error:"

50-- | Generalized monadic parsing constraint type

87-- | Generalized monadic parsing constraint type

51type MonadicParsing m = (P.MonadParsec () String m, Tok.TokenParsing m)

88type MonadicParsing m = (P.MonadParsec () String m, Tok.TokenParsing m)

@@ -55,7 +92,7 @@ someSpace' = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment)

56instance Text.Parser.Combinators.Parsing IdrisInnerParser where

93instance Text.Parser.Combinators.Parsing IdrisInnerParser where

57 eof = P.eof

94 eof = P.eof

58− unexpected msg = P.unexpected . P.Label . fromList $ msg

95+ unexpected msg = P.unexpected . P.Label . NonEmpty.fromList $ msg

59 try = P.try

96 try = P.try

60 (<?>) = (P.<?>)

97 (<?>) = (P.<?>)

61 notFollowedBy = P.notFollowedBy

98 notFollowedBy = P.notFollowedBy

@@ -78,10 +115,7 @@ instance {-# OVERLAPPING #-} Tok.TokenParsing IdrisParser where

115

79-- | Helper to run Idris inner parser based stateT parsers

116-- | Helper to run Idris inner parser based stateT parsers

80runparser :: StateT st IdrisInnerParser res -> st -> String -> String -> Either ParseError res

117runparser :: StateT st IdrisInnerParser res -> st -> String -> String -> Either ParseError res

81−runparser p i inputname s =

82− case P.parse (evalStateT p i) inputname s of

118+runparser p i inputname s = P.parse (evalStateT p i) inputname s

83− Left _ -> Left $ ParseError undefined --FIXME:

84− Right value -> Right value

119

86highlightP :: FC -> OutputAnnotation -> IdrisParser ()

120highlightP :: FC -> OutputAnnotation -> IdrisParser ()

87highlightP fc annot = do ist <- get

121highlightP fc annot = do ist <- get

@@ -318,8 +352,8 @@ identifier :: (MonadicParsing m) => m (String, FC)

318identifier = P.try $ do

352identifier = P.try $ do

319 (FC f (l, c) _) <- getFC

353 (FC f (l, c) _) <- getFC

320 ident <- identifierOrReserved

354 ident <- identifierOrReserved

321− when (ident `HS.member` reservedIdentifiers) $ P.unexpected . P.Label . fromList $ "reserved " ++ ident

355+ when (ident `HS.member` reservedIdentifiers) $ P.unexpected . P.Label . NonEmpty.fromList $ "reserved " ++ ident

322− when (ident == "_") $ P.unexpected . P.Label . fromList $ "wildcard"

356+ when (ident == "_") $ P.unexpected . P.Label . NonEmpty.fromList $ "wildcard"

323 return (ident, FC f (l, c) (l, c + length ident))

357 return (ident, FC f (l, c) (l, c + length ident))

324

358

325-- | Parses an identifier with possible namespace as a name

359-- | Parses an identifier with possible namespace as a name

@@ -331,7 +365,7 @@ maybeWithNS :: (MonadicParsing m) => m (String, FC) -> Bool -> [String] -> m (Na

331maybeWithNS parser ascend bad = do

365maybeWithNS parser ascend bad = do

332 fc <- getFC

366 fc <- getFC

333 i <- P.option "" (P.lookAhead (fst <$> identifier))

367 i <- P.option "" (P.lookAhead (fst <$> identifier))

334− when (i `elem` bad) $ P.unexpected . P.Label . fromList $ "reserved identifier"

368+ when (i `elem` bad) $ P.unexpected . P.Label . NonEmpty.fromList $ "reserved identifier"

335 let transf = if ascend then id else reverse

369 let transf = if ascend then id else reverse

336 (x, xs, fc) <- P.choice (transf (parserNoNS parser : parsersNS parser i))

370 (x, xs, fc) <- P.choice (transf (parserNoNS parser : parsersNS parser i))

337 return (mkName (x, xs), fc)

371 return (mkName (x, xs), fc)