{-# language ApplicativeDo #-}
{-# language DefaultSignatures #-}
{-# language OverloadedStrings #-}
{-# language TypeOperators #-}


module FlexTask.Generic.ParseInternal
  ( Parse(..)
  , parseInstanceSingleChoice
  , parseInstanceMultiChoice
  , parseInstanceSingleInputList
  , escaped
  , parseWithOrReport
  , reportWithFieldNumber
  , parseInfallibly
  , parseWithFallback
  , displayInputAnd
  ) where


import Control.Monad      (ap, void)
import Control.OutputCapable.Blocks (
  LangM,
  LangM',
  OutputCapable,
  ReportT,
  english,
  german,
  indent,
  text,
  translate,
  )
import Control.OutputCapable.Blocks.Generic (
  toAbort,
  )
import Data.Functor       (($>))
import Data.List.Extra    (drop1, dropEnd1, takeWhileEnd)
import Data.Text          (Text)
import GHC.Generics       (Generic(..), K1(..), M1(..), (:*:)(..))
import Text.Parsec
  ( ParseError
  , (<|>)
  , between
  , lookAhead
  , manyTill
  , notFollowedBy
  , optionMaybe
  , parse
  , sepBy
  , sourceColumn
  , spaces
  , try
  )
import Text.Parsec.Char   (anyChar, char, string)
import Text.Parsec.Error (
  errorMessages,
  errorPos,
  showErrorMessages,
  )
import Text.Parsec.String (Parser)
import Text.ParserCombinators.Parsec.Number (
  floating2,
  int,
  sign,
  )
import Yesod              (Textarea(..))

import qualified Data.Text    as T

import FlexTask.Processing.Text (
  argDelimiter,
  emptyMarker,
  inputEscape,
  listDelimiter,
  missingMarker
  )
import FlexTask.Generic.Form
  ( MultipleChoiceSelection
  , SingleChoiceSelection
  , SingleInputList(..)
  , multipleChoiceAnswer
  , singleChoiceAnswer
  , singleChoiceEmpty
  )




{- |
Class for generic parsing of types.
Bodyless instances can be declared for any type instancing Generic.
__Exception: Types with multiple constructors.__ Use utility functions for those or provide your own instance.
-}
class Parse a where
  formParser :: Parser a

  default formParser :: (Generic a, GParse (Rep a)) => Parser a
  formParser = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a)
-> ParsecT String () Identity (Rep a Any) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity (Rep a Any)
forall a. Parser (Rep a a)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse



class GParse f where
  gparse :: Parser (f a)



instance (GParse a, GParse b) => GParse (a :*: b) where
  gparse :: forall a. Parser ((:*:) a b a)
gparse = do
    a a
a <- Parser (a a)
forall a. Parser (a a)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse
    ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> ParsecT String () Identity String
parseText Text
argDelimiter
    b a
b <- Parser (b a)
forall a. Parser (b a)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse
    pure (a a
a a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b a
b)



-- | Meta-information (constructor names, etc.)
instance GParse a => GParse (M1 i c a) where
  gparse :: forall a. Parser (M1 i c a a)
gparse = a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 i c a a)
-> ParsecT String () Identity (a a)
-> ParsecT String () Identity (M1 i c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity (a a)
forall a. Parser (a a)
forall (f :: * -> *) a. GParse f => Parser (f a)
gparse



-- | Constants, additional parameters and recursion of kind *
instance Parse a => GParse (K1 i a) where
  gparse :: forall a. Parser (K1 i a a)
gparse = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a)
-> ParsecT String () Identity a
-> ParsecT String () Identity (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity a
forall a. Parse a => Parser a
formParser



parseString :: Parser String
parseString :: ParsecT String () Identity String
parseString = ParsecT String () Identity Char
-> ParsecT String () Identity ()
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String () Identity ()
 -> ParsecT String () Identity String)
-> ParsecT String () Identity ()
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity () -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT String () Identity () -> ParsecT String () Identity ())
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity () -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT String () Identity () -> ParsecT String () Identity ())
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$
  ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity String
escape ParsecT String () Identity String
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity String -> ParsecT String () Identity ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\"")


parseBool :: Parser Bool
parseBool :: Parser Bool
parseBool = do
  String
val <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"yes") ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"no"
  pure $ case String
val of
    String
"yes" -> Bool
True
    String
_     -> Bool
False


parseDouble :: Parser Double
parseDouble :: Parser Double
parseDouble = ParsecT String () Identity (Double -> Double)
-> Parser Double -> Parser Double
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap ParsecT String () Identity (Double -> Double)
forall a st. Num a => CharParser st (a -> a)
sign (Parser Double -> Parser Double) -> Parser Double -> Parser Double
forall a b. (a -> b) -> a -> b
$ Bool -> Parser Double
forall f st. Floating f => Bool -> CharParser st f
floating2 Bool
True



instance Parse Integer where
  formParser :: Parser Integer
formParser = Parser Integer -> Parser Integer
forall a. Parser a -> Parser a
escaped Parser Integer
forall i st. Integral i => CharParser st i
int



instance Parse Int where
  formParser :: Parser Int
formParser = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Parser Integer -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parse a => Parser a
formParser @Integer



instance Parse String where
  formParser :: ParsecT String () Identity String
formParser = ParsecT String () Identity String
-> ParsecT String () Identity String
forall a. Parser a -> Parser a
escaped ParsecT String () Identity String
parseString



instance Parse Text where
  formParser :: Parser Text
formParser = String -> Text
T.pack (String -> Text)
-> ParsecT String () Identity String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
forall a. Parse a => Parser a
formParser



instance Parse Textarea where
  formParser :: Parser Textarea
formParser = Text -> Textarea
Textarea (Text -> Textarea) -> Parser Text -> Parser Textarea
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
forall a. Parse a => Parser a
formParser



instance Parse Bool where
  formParser :: Parser Bool
formParser = Parser Bool -> Parser Bool
forall a. Parser a -> Parser a
escaped Parser Bool
parseBool



instance Parse Double where
  formParser :: Parser Double
formParser = Parser Double -> Parser Double
forall a. Parser a -> Parser a
escaped Parser Double
parseDouble


instance (Parse a, Parse b) => Parse (a,b)

instance (Parse a, Parse b, Parse c) => Parse (a,b,c)

instance (Parse a, Parse b, Parse c, Parse d) => Parse (a,b,c,d)

instance (Parse a, Parse b, Parse c, Parse d, Parse e) => Parse (a,b,c,d,e)

instance (Parse a, Parse b, Parse c, Parse d, Parse e, Parse f) => Parse (a,b,c,d,e,f)



parseList :: Parse a => Parser [a]
parseList :: forall a. Parse a => Parser [a]
parseList = ParsecT String () Identity [a] -> ParsecT String () Identity [a]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT String () Identity [a] -> ParsecT String () Identity [a]
forall a. Parser a -> Parser a
escaped ParsecT String () Identity [a]
forall {a}. ParsecT String () Identity [a]
parseEmpty) ParsecT String () Identity [a]
-> ParsecT String () Identity [a] -> ParsecT String () Identity [a]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity a
-> ParsecT String () Identity String
-> ParsecT String () Identity [a]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
sepBy ParsecT String () Identity a
forall a. Parse a => Parser a
formParser (Text -> ParsecT String () Identity String
parseText Text
listDelimiter)
    where
      parseEmpty :: ParsecT String () Identity [a]
parseEmpty = Text -> ParsecT String () Identity String
parseText Text
missingMarker ParsecT String () Identity String
-> [a] -> ParsecT String () Identity [a]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []


instance {-# Overlappable #-} Parse a => Parse [a] where
  formParser :: Parser [a]
formParser = Parser [a]
forall a. Parse a => Parser [a]
parseList


-- To avoid clash with TypeError instance in Parse.hs
instance Parse [String] where
  formParser :: Parser [String]
formParser = Parser [String]
forall a. Parse a => Parser [a]
parseList


instance Parse a => Parse (Maybe a) where
  formParser :: Parser (Maybe a)
formParser = do
    Maybe String
mValue <- ParsecT String () Identity String
-> ParsecT String () Identity (Maybe String)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (ParsecT String () Identity String
 -> ParsecT String () Identity (Maybe String))
-> ParsecT String () Identity String
-> ParsecT String () Identity (Maybe String)
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity String
-> ParsecT String () Identity String
forall a. Parser a -> Parser a
escaped (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ Text -> ParsecT String () Identity String
parseText Text
emptyMarker
    case Maybe String
mValue of
      Maybe String
Nothing -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> ParsecT String () Identity a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity a
forall a. Parse a => Parser a
formParser
      Just String
_  -> Maybe a -> Parser (Maybe a)
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing


instance Parse SingleChoiceSelection where
  formParser :: Parser SingleChoiceSelection
formParser = SingleChoiceSelection
-> (Int -> SingleChoiceSelection)
-> Maybe Int
-> SingleChoiceSelection
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SingleChoiceSelection
singleChoiceEmpty Int -> SingleChoiceSelection
singleChoiceAnswer (Maybe Int -> SingleChoiceSelection)
-> ParsecT String () Identity (Maybe Int)
-> Parser SingleChoiceSelection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity (Maybe Int)
forall a. Parse a => Parser a
formParser


instance Parse MultipleChoiceSelection where
  formParser :: Parser MultipleChoiceSelection
formParser = [Int] -> MultipleChoiceSelection
multipleChoiceAnswer ([Int] -> MultipleChoiceSelection)
-> ParsecT String () Identity [Int]
-> Parser MultipleChoiceSelection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity [Int]
parseWithEmptyMarker


instance Parse (SingleInputList Integer) where
  formParser :: Parser (SingleInputList Integer)
formParser = Parser Integer -> Parser (SingleInputList Integer)
forall a. Parser a -> Parser (SingleInputList a)
parseInstanceSingleInputList Parser Integer
forall i st. Integral i => CharParser st i
int


instance Parse (SingleInputList Int) where
  formParser :: Parser (SingleInputList Int)
formParser = Parser Int -> Parser (SingleInputList Int)
forall a. Parser a -> Parser (SingleInputList a)
parseInstanceSingleInputList Parser Int
forall i st. Integral i => CharParser st i
int


instance Parse (SingleInputList String) where
  formParser :: Parser (SingleInputList String)
formParser = ParsecT String () Identity String
-> Parser (SingleInputList String)
forall a. Parser a -> Parser (SingleInputList a)
parseInstanceSingleInputList ParsecT String () Identity String
parseString


instance Parse (SingleInputList Text) where
  formParser :: Parser (SingleInputList Text)
formParser = Parser Text -> Parser (SingleInputList Text)
forall a. Parser a -> Parser (SingleInputList a)
parseInstanceSingleInputList (Parser Text -> Parser (SingleInputList Text))
-> Parser Text -> Parser (SingleInputList Text)
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text)
-> ParsecT String () Identity String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
parseString


instance Parse (SingleInputList Textarea) where
  formParser :: Parser (SingleInputList Textarea)
formParser = Parser Textarea -> Parser (SingleInputList Textarea)
forall a. Parser a -> Parser (SingleInputList a)
parseInstanceSingleInputList (Parser Textarea -> Parser (SingleInputList Textarea))
-> Parser Textarea -> Parser (SingleInputList Textarea)
forall a b. (a -> b) -> a -> b
$ Text -> Textarea
Textarea (Text -> Textarea) -> (String -> Text) -> String -> Textarea
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Textarea)
-> ParsecT String () Identity String -> Parser Textarea
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
parseString


instance Parse (SingleInputList Bool) where
  formParser :: Parser (SingleInputList Bool)
formParser = Parser Bool -> Parser (SingleInputList Bool)
forall a. Parser a -> Parser (SingleInputList a)
parseInstanceSingleInputList Parser Bool
parseBool


instance Parse (SingleInputList Double) where
  formParser :: Parser (SingleInputList Double)
formParser = Parser Double -> Parser (SingleInputList Double)
forall a. Parser a -> Parser (SingleInputList a)
parseInstanceSingleInputList Parser Double
parseDouble


{- |
Parser for single choice answer of Enum types. Use as implementation of `formParser` for manual `Parse` instances.
Intended for use with types such as

@
data MyType = One | Two | Three deriving (Bounded, Enum, Eq)
@

that can not use a bodyless `Parse` instance.
-}
parseInstanceSingleChoice :: (Bounded a, Enum a, Eq a) => Parser a
parseInstanceSingleChoice :: forall a. (Bounded a, Enum a, Eq a) => Parser a
parseInstanceSingleChoice = Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> (Int -> Int) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> a) -> Parser Int -> ParsecT String () Identity a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
forall a. Parse a => Parser a
formParser



-- | Same as `parseInstanceSingleChoice`, but for parsing a List of the given type, i.e. a multiple choice version.
parseInstanceMultiChoice :: (Bounded a, Enum a, Eq a) => Parser [a]
parseInstanceMultiChoice :: forall a. (Bounded a, Enum a, Eq a) => Parser [a]
parseInstanceMultiChoice = (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> (Int -> Int) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1) ([Int] -> [a])
-> ParsecT String () Identity [Int]
-> ParsecT String () Identity [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity [Int]
parseWithEmptyMarker



{- |
Parser for a list of values inside a single input field.
Takes a parser for individual list values.
__Please note that it must not use the `escape` function found in this module.__
Use as implementation of `formParser` for manual `Parse` instances.
These instances are already provided for standard types as is.
-}
parseInstanceSingleInputList :: Parser a -> Parser (SingleInputList a)
parseInstanceSingleInputList :: forall a. Parser a -> Parser (SingleInputList a)
parseInstanceSingleInputList Parser a
parser = Parser (SingleInputList a) -> Parser (SingleInputList a)
forall a. Parser a -> Parser a
escaped (Parser (SingleInputList a) -> Parser (SingleInputList a))
-> Parser (SingleInputList a) -> Parser (SingleInputList a)
forall a b. (a -> b) -> a -> b
$ Parser (SingleInputList a)
contents Parser (SingleInputList a)
-> ParsecT String () Identity () -> Parser (SingleInputList a)
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
    where
      contents :: Parser (SingleInputList a)
contents = [a] -> SingleInputList a
forall a. [a] -> SingleInputList a
SingleInputList ([a] -> SingleInputList a)
-> ParsecT String () Identity [a] -> Parser (SingleInputList a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> Parser a
forall {u} {b}.
ParsecT String u Identity b -> ParsecT String u Identity b
withSpaces Parser a
parser Parser a
-> ParsecT String () Identity Char
-> ParsecT String () Identity [a]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
`sepBy` ParsecT String () Identity Char -> ParsecT String () Identity Char
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT String () Identity Char -> ParsecT String () Identity Char
forall {u} {b}.
ParsecT String u Identity b -> ParsecT String u Identity b
withSpaces (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
','))
      withSpaces :: ParsecT String u Identity b -> ParsecT String u Identity b
withSpaces = (ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String u Identity ()
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>)



parseWithEmptyMarker :: Parser [Int]
parseWithEmptyMarker :: ParsecT String () Identity [Int]
parseWithEmptyMarker = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0) ([Int] -> [Int])
-> ParsecT String () Identity [Int]
-> ParsecT String () Identity [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity [Int]
forall a. Parse a => Parser a
formParser



escape :: Parser String
escape :: ParsecT String () Identity String
escape = ParsecT String () Identity String
esc ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity String
esc
  where esc :: ParsecT String () Identity String
esc = Text -> ParsecT String () Identity String
parseText Text
inputEscape



{- |
Parses FlexTask answer escape characters enclosing the input.
Use this to wrap preexisting parsers that are used to parse a student solution.
Otherwise your parser will fail on the escape characters.
Parsers generated by `Parse` already consider the escaping and do not need to be wrapped.
-}
escaped :: Parser a -> Parser a
escaped :: forall a. Parser a -> Parser a
escaped = ParsecT String () Identity ()
-> ParsecT String () Identity String
-> ParsecT String () Identity a
-> ParsecT String () Identity a
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (ParsecT String () Identity String
escape ParsecT String () Identity String
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) (ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity String
escape)



parseText :: Text -> Parser String
parseText :: Text -> ParsecT String () Identity String
parseText Text
t = String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string (String -> ParsecT String () Identity String)
-> String -> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t



{- |
Parses a String with the given parser and embeds the result into the `OutputCapable` interface.
No value will be embedded in case of a `ParseError`. Instead, an error report is given then.
That report is built using the second function argument.
The report will automatically abort after displaying.
It is therefore not necessary to include a `refuse`, but it is not harmful either.
Adding a refuse will display text and cut off any following output as usual.
This can be useful for giving better error messages.
-}
parseWithOrReport ::
  (Monad m, OutputCapable (ReportT o m))
  => Parser a
  -> (String -> ParseError -> LangM (ReportT o m))
  -> String
  -> LangM' (ReportT o m) a
parseWithOrReport :: forall (m :: * -> *) o a.
(Monad m, OutputCapable (ReportT o m)) =>
Parser a
-> (String -> ParseError -> LangM (ReportT o m))
-> String
-> LangM' (ReportT o m) a
parseWithOrReport Parser a
parser String -> ParseError -> LangM (ReportT o m)
errorMsg String
answer =
  case Parser a -> String -> String -> Either ParseError a
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser a
parser String
"" String
answer of
    Left ParseError
failure  -> LangM (ReportT o m) -> LangM' (ReportT o m) a
forall (m :: * -> *) l o a b.
Monad m =>
GenericLangM l (GenericReportT l o m) a
-> GenericLangM l (GenericReportT l o m) b
toAbort (LangM (ReportT o m) -> LangM' (ReportT o m) a)
-> LangM (ReportT o m) -> LangM' (ReportT o m) a
forall a b. (a -> b) -> a -> b
$ String -> ParseError -> LangM (ReportT o m)
errorMsg String
answer ParseError
failure
    Right a
success -> a -> LangM' (ReportT o m) a
forall a. a -> GenericLangM Language (ReportT o m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
success


{- |
Parses a String with the given parser and embeds the result into the `OutputCapable` interface.
Use when you know that there will be no error (e.g., when the parser used is `formParser` and
the input form is "infallible" since only constructed from String text fields, single, multiple choice).
-}
parseInfallibly ::
  Applicative m
  => Parser a
  -> String
  -> m a
parseInfallibly :: forall (m :: * -> *) a. Applicative m => Parser a -> String -> m a
parseInfallibly Parser a
parser String
answer =
  case Parser a -> String -> String -> Either ParseError a
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser a
parser String
"" String
answer of
    Left ParseError
failure  -> String -> m a
forall a. HasCallStack => String -> a
error (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"The impossible happened: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
failure
    Right a
success -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
success


{- |
Parses a String with the given parser.
Allows for further processing of a possible parse error.
A second parser is used as a fallback in case of an error.
The result of both parsers is then used to construct the report.
Comments on `refuse`'s behaviour for `parseWithOrReport` also apply for this function.
This can be useful for giving more specific error messages,
e.g. checking a term for bracket consistency even if the parser failed early on.
-}
parseWithFallback ::
  (Monad m, OutputCapable (ReportT o m))
  => Parser a
  -- ^ Parser to use initially
  -> (String -> Maybe ParseError -> ParseError -> LangM (ReportT o m))
  -- ^ How to produce an error report based on:
  -- ^ 1. The input string
  -- ^ 2. The possible parse error of the fallback parser
  -- ^ 3. The original parse error
  -> Parser ()
  -- ^ The secondary parser to use in case of a parse error.
  -- ^ Only used for generating possible further errors, thus does not return a value.
  -> String
  -- ^ The input
  -> LangM' (ReportT o m) a
  -- ^ The finished error report or embedded value
parseWithFallback :: forall (m :: * -> *) o a.
(Monad m, OutputCapable (ReportT o m)) =>
Parser a
-> (String
    -> Maybe ParseError -> ParseError -> LangM (ReportT o m))
-> ParsecT String () Identity ()
-> String
-> LangM' (ReportT o m) a
parseWithFallback Parser a
parser String -> Maybe ParseError -> ParseError -> LangM (ReportT o m)
messaging ParsecT String () Identity ()
fallBackParser =
  Parser a
-> (String -> ParseError -> LangM (ReportT o m))
-> String
-> LangM' (ReportT o m) a
forall (m :: * -> *) o a.
(Monad m, OutputCapable (ReportT o m)) =>
Parser a
-> (String -> ParseError -> LangM (ReportT o m))
-> String
-> LangM' (ReportT o m) a
parseWithOrReport
    Parser a
parser
    (\String
a -> String -> Maybe ParseError -> ParseError -> LangM (ReportT o m)
messaging String
a ((ParseError -> Maybe ParseError)
-> (() -> Maybe ParseError)
-> Either ParseError ()
-> Maybe ParseError
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseError -> Maybe ParseError
forall a. a -> Maybe a
Just (Maybe ParseError -> () -> Maybe ParseError
forall a b. a -> b -> a
const Maybe ParseError
forall a. Maybe a
Nothing) (ParsecT String () Identity ()
-> String -> String -> Either ParseError ()
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse ParsecT String () Identity ()
fallBackParser String
"" String
a)))



{- |
Provide error report with positional information relative to an input form.
-}
reportWithFieldNumber :: OutputCapable m => String -> ParseError -> LangM m
reportWithFieldNumber :: forall (m :: * -> *).
OutputCapable m =>
String -> ParseError -> LangM m
reportWithFieldNumber String
input ParseError
e = do
    State (Map Language String) () -> LangM m
forall l (m :: * -> *).
GenericOutputCapable l m =>
State (Map l String) () -> GenericLangM l m ()
translate (State (Map Language String) () -> LangM m)
-> State (Map Language String) () -> LangM m
forall a b. (a -> b) -> a -> b
$ do
      String -> State (Map Language String) ()
german (String -> State (Map Language String) ())
-> String -> State (Map Language String) ()
forall a b. (a -> b) -> a -> b
$ String
"Fehler in Eingabefeld" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorInfo
      String -> State (Map Language String) ()
german (String -> State (Map Language String) ())
-> String -> State (Map Language String) ()
forall a b. (a -> b) -> a -> b
$ String
"an Position" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
relativeErrorPos
      String -> State (Map Language String) ()
english (String -> State (Map Language String) ())
-> String -> State (Map Language String) ()
forall a b. (a -> b) -> a -> b
$ String
"Error in input field" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorInfo
      String -> State (Map Language String) ()
english (String -> State (Map Language String) ())
-> String -> State (Map Language String) ()
forall a b. (a -> b) -> a -> b
$ String
"at position" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
relativeErrorPos
    LangM m -> LangM m
forall l (m :: * -> *).
GenericOutputCapable l m =>
GenericLangM l m () -> GenericLangM l m ()
indent (LangM m -> LangM m) -> LangM m -> LangM m
forall a b. (a -> b) -> a -> b
$ String -> LangM m
forall l (m :: * -> *).
GenericOutputCapable l m =>
String -> GenericLangM l m ()
text String
errors
    pure ()
  where
    fieldNum :: String
fieldNum = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDelimiter String
consumed) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    errors :: String
errors = String
-> String -> String -> String -> String -> [Message] -> String
showErrorMessages
      String
"or"
      String
"unknown parse error"
      String
"expecting"
      String
"unexpected"
      String
"end of input"
      ([Message] -> String) -> [Message] -> String
forall a b. (a -> b) -> a -> b
$ ParseError -> [Message]
errorMessages ParseError
e
    isDelimiter :: Char -> Bool
isDelimiter = (Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
'\a',Char
'\b']
    errorAt :: Int
errorAt = SourcePos -> Int
sourceColumn (SourcePos -> Int) -> SourcePos -> Int
forall a b. (a -> b) -> a -> b
$ ParseError -> SourcePos
errorPos ParseError
e
    (String
consumed, String
rest) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
errorAt String
input
    restOfField :: String
restOfField = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDelimiter) String
rest
    fieldUntilError :: String
fieldUntilError = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhileEnd (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDelimiter) String
consumed
    causedError :: String
causedError = String -> String
forall a. [a] -> [a]
drop1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
dropEnd1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
fieldUntilError String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
restOfField
    relativeErrorPos :: String
relativeErrorPos = String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
fieldUntilError Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2)
    errorInfo :: String
errorInfo = String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldNum String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
causedError String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "


displayInputAnd ::
  OutputCapable m =>
  (Maybe a -> ParseError -> LangM m)
  -> String -> Maybe a -> ParseError -> LangM m
displayInputAnd :: forall (m :: * -> *) a.
OutputCapable m =>
(Maybe a -> ParseError -> LangM m)
-> String -> Maybe a -> ParseError -> LangM m
displayInputAnd Maybe a -> ParseError -> LangM m
messaging String
a Maybe a
ma ParseError
err = do
  State (Map Language String) () -> LangM m
forall l (m :: * -> *).
GenericOutputCapable l m =>
State (Map l String) () -> GenericLangM l m ()
translate (State (Map Language String) () -> LangM m)
-> State (Map Language String) () -> LangM m
forall a b. (a -> b) -> a -> b
$ do
    String -> State (Map Language String) ()
german (String -> State (Map Language String) ())
-> String -> State (Map Language String) ()
forall a b. (a -> b) -> a -> b
$ String
"Fehler in \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" : "
    String -> State (Map Language String) ()
english (String -> State (Map Language String) ())
-> String -> State (Map Language String) ()
forall a b. (a -> b) -> a -> b
$ String
"Error in \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" : "
  LangM m -> LangM m
forall l (m :: * -> *).
GenericOutputCapable l m =>
GenericLangM l m () -> GenericLangM l m ()
indent (LangM m -> LangM m) -> LangM m -> LangM m
forall a b. (a -> b) -> a -> b
$ Maybe a -> ParseError -> LangM m
messaging Maybe a
ma ParseError
err
  pure ()