{-# 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