@@ -26,26 +26,63 @@ import Control.Monad.State.Strict
2626import Data.Char
2727import qualified Data.HashSet as HS
2828import Data.List
29+import Data.List.NonEmpty (NonEmpty(..))
30+import qualified Data.List.NonEmpty as NonEmpty
2931import qualified Data.Map as M
3032import Data.Maybe
33+import qualified Data.Set as Set
3134import qualified Data.Text as T
3235import System.FilePath
33−import Data.List.NonEmpty (fromList)
3436import qualified Text.Parser.Char
3537import qualified Text.Parser.Combinators
3638import qualified Text.Parser.Token as Tok
39+import Text.PrettyPrint.ANSI.Leijen ((<>), (<+>))
3740import qualified Text.PrettyPrint.ANSI.Leijen as PP
3841import Text.Megaparsec ((<?>))
3942import qualified Text.Megaparsec as P
4043import qualified Text.Megaparsec.Char as P
4144import qualified Text.Megaparsec.Char.Lexer as P hiding (space)
4245
43−newtype ParseError = ParseError { parseErrorDoc :: PP.Doc }
4446
4547-- | Idris parser with state used during parsing
4648type IdrisParser = StateT IState IdrisInnerParser
4749type IdrisInnerParser = P.Parsec () String
4850type 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:"
4986
5087-- | Generalized monadic parsing constraint type
5188type MonadicParsing m = (P.MonadParsec () String m, Tok.TokenParsing m)
@@ -55,7 +92,7 @@ someSpace' = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment)
5592
5693instance Text.Parser.Combinators.Parsing IdrisInnerParser where
5794 eof = P.eof
58− unexpected msg = P.unexpected . P.Label . fromList $ msg
95+ unexpected msg = P.unexpected . P.Label . NonEmpty.fromList $ msg
5996 try = P.try
6097 (<?>) = (P.<?>)
6198 notFollowedBy = P.notFollowedBy
@@ -78,10 +115,7 @@ instance {-# OVERLAPPING #-} Tok.TokenParsing IdrisParser where
78115
79116-- | Helper to run Idris inner parser based stateT parsers
80117runparser :: 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
83− Left _ -> Left $ ParseError undefined --FIXME:
84− Right value -> Right value
118+runparser p i inputname s = P.parse (evalStateT p i) inputname s
85119
86120highlightP :: FC -> OutputAnnotation -> IdrisParser ()
87121highlightP fc annot = do ist <- get
@@ -318,8 +352,8 @@ identifier :: (MonadicParsing m) => m (String, FC)
318352identifier = P.try $ do
319353 (FC f (l, c) _) <- getFC
320354 ident <- identifierOrReserved
321− when (ident `HS.member` reservedIdentifiers) $ P.unexpected . P.Label . fromList $ "reserved " ++ ident
322− when (ident == "_") $ P.unexpected . P.Label . fromList $ "wildcard"
355+ when (ident `HS.member` reservedIdentifiers) $ P.unexpected . P.Label . NonEmpty.fromList $ "reserved " ++ ident
356+ when (ident == "_") $ P.unexpected . P.Label . NonEmpty.fromList $ "wildcard"
323357 return (ident, FC f (l, c) (l, c + length ident))
324358
325359-- | Parses an identifier with possible namespace as a name
@@ -331,7 +365,7 @@ maybeWithNS :: (MonadicParsing m) => m (String, FC) -> Bool -> [String] -> m (Na
331365maybeWithNS parser ascend bad = do
332366 fc <- getFC
333367 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"
335369 let transf = if ascend then id else reverse
336370 (x, xs, fc) <- P.choice (transf (parserNoNS parser : parsersNS parser i))
337371 return (mkName (x, xs), fc)