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