Simplify and allow for sharing of parsing/pre-processing, also adding…

… report facilities (#77)

---------

Co-authored-by: Janis Voigtländer <[email protected]>

flex-tasks/src/FlexTask/DefaultConfig.hs

@@ -260,12 +260,47 @@ dParse = [rQ|
 Module for parsing the student submission.
 Must contain the function
 
-parseSubmission :: String -> Either ParseError Solution
+parseSubmission ::
+  (Monad m, OutputCapable (ReportT o m))
+  => String
+  -> LangM' (ReportT o m) Solution
 
 where the given String is the submission.
-The parsers used are those of 'Text.Parsec'.
+This function should first apply parsing to the submission,
+then embed the result into 'OutputCapable'.
+The type 'LangM' (ReportT o m) Solution' is a specialization of the more general 'LangM' m Solution'.
+'LangM' m Solution' represents sequential output like 'LangM m' or 'Rated m',
+but provides a value of type Solution afterwards.
+The function thus enables more complex reporting (e.g., of errors)
+than might be possible by purely using basic parsers alone.
+The final result is passed to the check functions to generate feedback.
+
+The parsers used throughout are those of 'Text.Parsec'.
 Refer to its documentation if necessary.
 
+To implement parseSubmission, you will typically invoke 'useParser' and
+possibly 'parseWithFallback' or 'parseWithMessage', all
+supplied by 'FlexTask.Generic.Parse'. In simple situations, '<&>' may suffice.
+The 'useParser' function takes a parser and the 'String' input as arguments
+and embeds the result directly into 'OutputCapable'.
+This function directly reads the form results.
+It is enough if you do not need additional processing of the input.
+The 'parseWithFallback' function can be used to additionally parse/process
+Strings from among the form result, that is, individual input fields.
+It should be used after 'useParser', instead of on its own.
+'parseWithFallback' takes a parser, messaging function, fallback parser and the input.
+The secondary parser is used as a simpler sanity check on the input in case
+of an error with the primary parser.
+The possible error of the fallback parser and the original error
+are then fed to the messaging function to construct the report.
+Use this to produce more sophisticated error messages.
+
+If you want to chain multiple parsing steps, e.g. with 'parseWithFallback',
+use '$>>=' of 'Control.OutputCapable.Blocks.Generic'.
+This operation can be seen as a '>>=' equivalent for 'LangM''.
+Example:
+'useParser parseInput input $>>= \s -> parseWithFallback p someFunc fallback s $>>= pure . ...'
+
 As with forms, a generic parser interface is available.
 The steps are similar:
 Derive Generic for your data type and include an instance declaration of 'Parse' without an implementation.
@@ -281,23 +316,27 @@ Instead, use bodyless instances for the component types where possible
 and use custom parsers for those where not applicable.
 Finally, use the bodyless instance method for the entire type.
 This is again necessary to avoid encoding problems that are caused internally by argument delimiters.
-
-To implement parseSubmission, you can use the 'useParser' function, again supplied by 'FlexTask.Generic.Parse'.
-It only takes your parser as an argument.
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 -}
 
 module Parse (parseSubmission) where
 
 
+import Control.OutputCapable.Blocks (
+  LangM',
+  ReportT,
+  OutputCapable,
+  )
 import FlexTask.Generic.Parse  (parseInput, useParser)
-import Text.Parsec             (ParseError)
 
 import Global
 
 
 
-parseSubmission :: String -> Either ParseError Solution
+parseSubmission ::
+  (Monad m, OutputCapable (ReportT o m))
+  => String
+  -> LangM' (ReportT o m) Solution
 parseSubmission = useParser parseInput
 
 |]

flex-tasks/src/FlexTask/Generic/ParseInternal.hs

@@ -9,26 +9,50 @@ module FlexTask.Generic.ParseInternal
   , parseInstanceMultiChoice
   , escaped
   , useParser
+  , parseWithFallback
+  , parseWithMessaging
   ) where
 
 
 import Control.Monad      (void)
+import Control.Monad.State (State)
+import Control.OutputCapable.Blocks (
+  Language,
+  LangM',
+  OutputCapable,
+  ReportT,
+  english,
+  german,
+  indent,
+  translate,
+  )
+import Control.OutputCapable.Blocks.Generic (
+  toAbort,
+  )
+import Data.Map           (Map)
 import Data.Text          (Text)
 import GHC.Generics       (Generic(..), K1(..), M1(..), (:*:)(..))
 import Text.Parsec
   ( ParseError
   , (<|>)
   , between
+  , eof
   , lookAhead
   , manyTill
   , many1
   , notFollowedBy
   , optionMaybe
   , parse
   , sepBy
+  , sourceColumn
   , try
   )
-import Text.Parsec.Char   (anyChar, char, digit, string)
+import Text.Parsec.Char   (anyChar, char, digit, spaces, string)
+import Text.Parsec.Error (
+  errorMessages,
+  errorPos,
+  showErrorMessages,
+  )
 import Text.Parsec.String (Parser)
 import Yesod              (Textarea(..))
 
@@ -230,5 +254,97 @@ parseText t = string $ T.unpack t
 
 
 
-useParser :: Parser a -> String -> Either ParseError a
-useParser p = parse p ""
+{- |
+Parses a String with the given input form 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.
+Error reports provide positional information of the error in the input form.
+-}
+useParser
+  :: (Monad m, OutputCapable (ReportT o m))
+  => Parser a
+  -> String
+  -> LangM' (ReportT o m) a
+useParser p = parseWithOrReport p showWithFieldNumber
+
+
+
+parseWithOrReport ::
+  (Monad m, OutputCapable (ReportT o m))
+  => Parser a
+  -> (String -> ParseError -> State (Map Language String) ())
+  -> String
+  -> LangM' (ReportT o m) a
+parseWithOrReport parser errorMsg answer =
+  case parse parser "" answer of
+    Left failure  -> toAbort $ indent $ translate $ errorMsg answer failure
+    Right success -> pure 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.
+This can be useful for giving better 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
+  -> (Maybe ParseError -> ParseError -> State (Map Language String) ())
+  -- ^ How to produce an error report based on:
+  -- ^ 1. The possible parse error of the fallback parser
+  -- ^ 2. 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 parser messaging fallBackParser =
+  parseWithOrReport
+    (fully parser)
+    (\a err -> displayInput a >>
+      messaging (either Just (const Nothing) (parse (fully fallBackParser) "" a)) err)
+  where
+    fully p = spaces *> p <* eof
+    displayInput a = do
+      german $ "Fehler in \"" ++ a ++ "\" : "
+      english $ "Error in \"" ++ a ++ "\" : "
+
+
+{- |
+like `parseWithFallback`, but does not use a second parser.
+The report is constructed out of the initial parse error only.
+-}
+parseWithMessaging ::
+  (Monad m, OutputCapable (ReportT o m))
+  => Parser a
+  -- ^ Parser to use
+  -> (ParseError -> State (Map Language String) ())
+  -- ^ How to construct the error report
+  -> String
+  -- ^ The input
+  -> LangM' (ReportT o m) a
+  -- ^ The finished error report or embedded value
+parseWithMessaging parser messaging = parseWithFallback parser (const messaging) undefined
+
+
+
+showWithFieldNumber :: String -> ParseError -> State (Map Language String) ()
+showWithFieldNumber input e = do
+    german $ "Fehler in Eingabefeld " ++ fieldNum ++ ":" ++ errors
+    english $ "Error in input field " ++ fieldNum ++ ":" ++ errors
+  where
+    fieldNum = show $ length (filter (=='\a') consumed) `div` 2 + 1
+    errors = showErrorMessages
+      "or"
+      "unknown parse error"
+      "expecting"
+      "unexpected"
+      "end of input"
+      $ errorMessages e
+    consumed = take (sourceColumn $ errorPos e) input

flex-tasks/src/FlexTask/InterpreterHelper.hs

@@ -1,15 +1,12 @@
-
+{-# language ApplicativeDo #-}
 module FlexTask.InterpreterHelper (syntaxAndSemantics) where
 
 
-import Control.OutputCapable.Blocks     (LangM, Rated, ReportT, code, refuse)
-import Control.OutputCapable.Blocks.Type
-import Data.Either                      (fromRight)
-import Text.Parsec                      (ParseError, sourceColumn)
-import Text.Parsec.Error (
-  errorMessages,
-  errorPos,
-  showErrorMessages,
+import Control.OutputCapable.Blocks     (LangM, LangM', Rated, ReportT)
+import Control.OutputCapable.Blocks.Type (
+  Output,
+  getOutputSequenceAndResult,
+  getOutputSequenceWithRating,
   )
 
 
@@ -18,45 +15,23 @@ type Report = ReportT Output IO
 
 
 syntaxAndSemantics
-  :: (String -> Either ParseError b)
+  :: (String -> LangM' Report b)
   -> (a -> FilePath -> b -> LangM Report)
   -> (a -> FilePath -> b -> Rated Report)
   -> String
   -> a
   -> FilePath
   -> IO ([Output], Maybe (Maybe Rational, [Output]))
-syntaxAndSemantics parser syntax semantics input tData path  = do
-  let
-    parsed = parser input
-    syn = either
-      (refuse . code . showWithFieldNumber input)
-      (syntax tData path)
-      parsed
-  synRes <- getOutputSequence syn
-  if any isAbort synRes
-    then
-      pure (synRes,Nothing)
-    else do
-      let sem = semantics tData path (fromRight undefined parsed)
-      semRes <- getOutputSequenceWithRating sem
-      pure (synRes, Just semRes)
-
-
-showWithFieldNumber :: String -> ParseError -> String
-showWithFieldNumber input e = "Error in input field " ++ fieldNum ++ ":" ++ errors
-  where
-    fieldNum = show $ length (filter (=='\a') consumed) `div` 2 + 1
-    errors = showErrorMessages
-      "or"
-      "unknown parse error"
-      "expecting"
-      "unexpected"
-      "end of input"
-      $ errorMessages e
-    consumed = take (sourceColumn $ errorPos e) input
-
-
-isAbort :: Output -> Bool
-isAbort (Refuse _)          = True
-isAbort (Assertion False _) = True
-isAbort _                   = False
+syntaxAndSemantics preprocess syntax semantics input tData path  = do
+  (mParseResult,parseOutput) <- getOutputSequenceAndResult $ preprocess input
+  case mParseResult of
+    Nothing          -> pure (parseOutput,Nothing)
+    Just parseResult -> do
+      (synSuccess,synRes) <- getOutputSequenceAndResult $ syntax tData path parseResult
+      let parseAndSyntax = parseOutput ++ synRes
+      case synSuccess of
+        Nothing -> pure (parseAndSyntax,Nothing)
+        Just () -> do
+          let sem = semantics tData path parseResult
+          semRes <- getOutputSequenceWithRating sem
+          pure (parseAndSyntax, Just semRes)