{-# 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 (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 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 (f :: * -> *).
Foldable f =>
f (ParseErrorExplanation LinePos) -> 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