{-# LANGUAGE OverloadedStrings #-} module SimpleParser.Interactive ( ErrorStyle (..) , renderInteractive , 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 (..), prettyErrors) import Errata.Styles (fancyPointer, fancyStyle) import SimpleParser.Errata (LinePosExplainable, 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) renderInteractive :: (LinePosExplainable l s e) => ErrorStyle -> String -> Maybe (ParseResult l s e a) -> IO () renderInteractive :: ErrorStyle -> String -> Maybe (ParseResult l s e a) -> IO () renderInteractive ErrorStyle errStyle String input = \case 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 -> PointerStyle -> String -> ParseError l s e -> Block forall l s e. LinePosExplainable l s e => Style -> PointerStyle -> String -> ParseError l s e -> Block errataParseError Style fancyStyle PointerStyle fancyPointer 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 Header -> [Block] -> Maybe Header -> Errata Errata Maybe Header forall a. Maybe a Nothing [Block] blocks Maybe Header 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 (Pos s)] -> Builder forall p (f :: * -> *). (HasLinePos p, Foldable f) => f (ParseErrorExplanation p) -> Builder buildAllParseErrorExplanations ((ParseError l s e -> ParseErrorExplanation (Pos s)) -> [ParseError l s e] -> [ParseErrorExplanation (Pos s)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ParseError l s e -> ParseErrorExplanation (Pos s) forall s l e. (TextBuildable (Token s), TextBuildable (Chunk s), 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 Header -> IO () TIO.putStrLn (Builder -> Header TB.run (Builder "Errors:\n" Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder b)) Just (ParseResultSuccess ParseSuccess s a _) -> String -> IO () putStrLn String "Success" parseInteractiveStyle :: (s ~ LinePosStream Text, Explainable l s e) => ErrorStyle -> Parser l s e a -> String -> IO (Maybe a) parseInteractiveStyle :: ErrorStyle -> Parser l s e a -> String -> IO (Maybe a) parseInteractiveStyle ErrorStyle errStyle Parser l s e a parser String input = do let mres :: Maybe (ParseResult l s e a) mres = 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) (Header -> LinePosStream Header forall s. s -> LinePosStream s newLinePosStream (String -> Header T.pack String input)) ErrorStyle -> String -> Maybe (ParseResult l s e a) -> IO () forall l s e a. LinePosExplainable l s e => ErrorStyle -> String -> Maybe (ParseResult l s e a) -> IO () renderInteractive ErrorStyle errStyle String input Maybe (ParseResult l s e a) mres let res :: Maybe a res = case Maybe (ParseResult l s e a) mres of { Just (ParseResultSuccess (ParseSuccess s _ a a)) -> a -> Maybe a forall a. a -> Maybe a Just a a; Maybe (ParseResult l s e a) _ -> Maybe a forall a. Maybe a Nothing } Maybe a -> IO (Maybe a) forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe a res parseInteractive :: (s ~ LinePosStream Text, Explainable l s e) => Parser l s e a -> String -> IO (Maybe a) parseInteractive :: Parser l s e a -> String -> IO (Maybe a) parseInteractive = ErrorStyle -> Parser l s e a -> String -> IO (Maybe a) forall s l e a. (s ~ LinePosStream Header, Explainable l s e) => ErrorStyle -> Parser l s e a -> String -> IO (Maybe a) parseInteractiveStyle ErrorStyle ErrorStyleErrata