{-# 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 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 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 :: forall l s e a. LinePosExplainable l s e => 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall l s e. LinePosExplainable l s e => Style -> PointerStyle -> String -> ParseError l s e -> Block errataParseError Style fancyStyle PointerStyle fancyPointer String "<interactive>") (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 forall a. Maybe a Nothing [Block] blocks forall a. Maybe a Nothing pretty :: Text pretty = 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 = forall p (f :: * -> *). (HasLinePos p, Foldable f) => f (ParseErrorExplanation p) -> Builder buildAllParseErrorExplanations (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall s l e. (TextBuildable (Token s), TextBuildable (Chunk s), Explainable l s e) => ParseError l s e -> ParseErrorExplanation (Pos s) explainParseError (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" 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 :: forall s l e a. (s ~ LinePosStream Header, Explainable l s e) => 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 = forall l s e a. Parser l s e a -> s -> Maybe (ParseResult l s e a) runParser (Parser l s e a parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* forall s (m :: * -> *) l e. (Stream s, Monad m) => ParserT l s e m () matchEnd) (forall s. s -> LinePosStream s newLinePosStream (String -> Header T.pack String input)) 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)) -> forall a. a -> Maybe a Just a a; Maybe (ParseResult l s e a) _ -> forall a. Maybe a Nothing } 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 :: forall s l e a. (s ~ LinePosStream Header, Explainable l s e) => Parser l s e a -> String -> IO (Maybe a) parseInteractive = 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