{-# LANGUAGE OverloadedStrings #-} module SimpleParser.Interactive ( ErrorStyle (..) , parseInteractiveStyle , parseInteractive ) where import Data.Foldable (toList) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO import qualified Data.Text.Lazy.IO as TLIO import Errata (Errata (..), fancyStyle, prettyErrors) import SimpleParser.Errata (errataParseError) import SimpleParser.Explain (Explainable, buildAllParseErrorExplanations, explainParseError) import SimpleParser.Input (matchEnd) import SimpleParser.Parser (Parser, runParser) import SimpleParser.Result (ParseErrorBundle (..), ParseResult (..), ParseSuccess (..)) import SimpleParser.Stream (LinePosStream, newLinePosStream) import qualified Text.Builder as TB data ErrorStyle = ErrorStyleErrata | ErrorStyleExplain deriving stock (ErrorStyle -> ErrorStyle -> Bool (ErrorStyle -> ErrorStyle -> Bool) -> (ErrorStyle -> ErrorStyle -> Bool) -> Eq ErrorStyle forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: ErrorStyle -> ErrorStyle -> Bool $c/= :: ErrorStyle -> ErrorStyle -> Bool == :: ErrorStyle -> ErrorStyle -> Bool $c== :: ErrorStyle -> ErrorStyle -> Bool Eq, Int -> ErrorStyle -> ShowS [ErrorStyle] -> ShowS ErrorStyle -> String (Int -> ErrorStyle -> ShowS) -> (ErrorStyle -> String) -> ([ErrorStyle] -> ShowS) -> Show ErrorStyle forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [ErrorStyle] -> ShowS $cshowList :: [ErrorStyle] -> ShowS show :: ErrorStyle -> String $cshow :: ErrorStyle -> String showsPrec :: Int -> ErrorStyle -> ShowS $cshowsPrec :: Int -> ErrorStyle -> ShowS Show) parseInteractiveStyle :: (s ~ LinePosStream Text, Explainable l s e, Show a) => ErrorStyle -> Parser l s e a -> String -> IO () parseInteractiveStyle :: ErrorStyle -> Parser l s e a -> String -> IO () parseInteractiveStyle ErrorStyle errStyle Parser l s e a parser String input = case Parser l s e a -> s -> Maybe (ParseResult l s e a) forall l s e a. Parser l s e a -> s -> Maybe (ParseResult l s e a) runParser (Parser l s e a parser Parser l s e a -> ParserT l s e Identity () -> Parser l s e a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* ParserT l s e Identity () forall s (m :: * -> *) l e. (Stream s, Monad m) => ParserT l s e m () matchEnd) (Text -> LinePosStream Text forall s. s -> LinePosStream s newLinePosStream (String -> Text T.pack String input)) of Maybe (ParseResult l s e a) Nothing -> String -> IO () putStrLn String "No result." Just (ParseResultError (ParseErrorBundle NESeq (ParseError l s e) es)) -> case ErrorStyle errStyle of ErrorStyle ErrorStyleErrata -> let blocks :: [Block] blocks = (ParseError l s e -> Block) -> [ParseError l s e] -> [Block] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Style -> String -> ParseError l s e -> Block forall l s e. LinePosExplainable l s e => Style -> String -> ParseError l s e -> Block errataParseError Style fancyStyle String "<interactive>") (NESeq (ParseError l s e) -> [ParseError l s e] forall (t :: * -> *) a. Foldable t => t a -> [a] toList NESeq (ParseError l s e) es) errata :: Errata errata = Maybe Text -> [Block] -> Maybe Text -> Errata Errata Maybe Text forall a. Maybe a Nothing [Block] blocks Maybe Text forall a. Maybe a Nothing pretty :: Text pretty = String -> [Errata] -> Text forall source. Source source => source -> [Errata] -> Text prettyErrors String input [Errata errata] in Text -> IO () TLIO.putStrLn Text pretty ErrorStyle ErrorStyleExplain -> let b :: Builder b = [ParseErrorExplanation LinePos] -> Builder forall p (f :: * -> *). (HasLinePos p, Foldable f) => f (ParseErrorExplanation p) -> Builder buildAllParseErrorExplanations ((ParseError l s e -> ParseErrorExplanation LinePos) -> [ParseError l s e] -> [ParseErrorExplanation LinePos] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ParseError l s e -> ParseErrorExplanation LinePos forall l s e. Explainable l s e => ParseError l s e -> ParseErrorExplanation (Pos s) explainParseError (NESeq (ParseError l s e) -> [ParseError l s e] forall (t :: * -> *) a. Foldable t => t a -> [a] toList NESeq (ParseError l s e) es)) in Text -> IO () TIO.putStrLn (Builder -> Text TB.run (Builder "Errors:\n" Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder b)) Just (ParseResultSuccess (ParseSuccess s _ a a)) -> String -> IO () putStrLn String "Success:" IO () -> IO () -> IO () forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> a -> IO () forall a. Show a => a -> IO () print a a parseInteractive :: (s ~ LinePosStream Text, Explainable l s e, Show a) => Parser l s e a -> String -> IO () parseInteractive :: Parser l s e a -> String -> IO () parseInteractive = ErrorStyle -> Parser l s e a -> String -> IO () forall s l e a. (s ~ LinePosStream Text, Explainable l s e, Show a) => ErrorStyle -> Parser l s e a -> String -> IO () parseInteractiveStyle ErrorStyle ErrorStyleErrata