{-# LANGUAGE OverloadedStrings #-}

{- |
Various text processing functions used to format input for display.
-}

module FlexTask.Processing.Text
  ( -- * Control Sequences
    -- $control
    argDelimiter
  , listDelimiter
  , inputEscape
  , missingMarker
  , emptyMarker
    -- * Formatting Functions
  , formatAnswer
  , formatIfFlexSubmission
  , formatForJS
  , removeUnicodeEscape
    -- * Form Duplication for Autotool Comment View
  , uniqueFormCopy
    -- * Internationalization
  , supportedLanguages
  ) where


import Data.Char                        (isAscii, isDigit)
import Data.List.Extra                  (replace)
import Data.Maybe                       (fromMaybe)
import Data.Text                        (Text)
import Numeric                          (showHex)
import Text.Blaze.Html                  (Html, preEscapedToHtml)
import Text.Blaze.Html.Renderer.String  (renderHtml)
import Text.Read                        (readMaybe)
import Text.Shakespeare.I18N            (Lang)

import qualified Data.Text as T



{- $control
Student answers for FlexTasks are compiled into a single String after retrieval.
The answer String contains control sequences which encode the structure of the input form.
-}

-- | Outer delimiter for individual fields.
argDelimiter :: Text
argDelimiter :: Lang
argDelimiter = Lang
"\a\a"

-- | Inner delimiter for elements of a field list.
listDelimiter :: Text
listDelimiter :: Lang
listDelimiter = Lang
"\b\b"

-- | Sequence denoting the start and end of a fields value.
inputEscape :: Text
inputEscape :: Lang
inputEscape = Lang
"\""

-- | Marker for a missing field
missingMarker :: Text
missingMarker :: Lang
missingMarker = Lang
"Missing"

-- | Marker for a blank optional field
emptyMarker :: Text
emptyMarker :: Lang
emptyMarker = Lang
"None"


escape :: Text -> Text
escape :: Lang -> Lang
escape Lang
t = Lang
inputEscape Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> String -> Lang
T.pack (Lang -> String
forall a. Show a => a -> String
show Lang
t) Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> Lang
inputEscape



process :: [Text] -> Text
process :: [Lang] -> Lang
process []   = Lang -> Lang
escape Lang
"Missing"
process [Lang]
s    = Lang -> [Lang] -> Lang
T.intercalate Lang
listDelimiter ([Lang] -> Lang) -> [Lang] -> Lang
forall a b. (a -> b) -> a -> b
$ (Lang -> Lang) -> [Lang] -> [Lang]
forall a b. (a -> b) -> [a] -> [b]
map (Lang -> Lang
escape (Lang -> Lang) -> (Lang -> Lang) -> Lang -> Lang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lang -> Lang
checkEmpty) [Lang]
s
  where
    checkEmpty :: Lang -> Lang
checkEmpty Lang
t = if Lang -> Bool
T.null Lang
t then Lang
"None" else Lang
t



-- | format a list of (nested) individual answers into a single answer String
formatAnswer :: [[[Text]]] -> Maybe Text
formatAnswer :: [[[Lang]]] -> Maybe Lang
formatAnswer [[[Lang]]]
values
  | ([[Lang]] -> Bool) -> [[[Lang]]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (([Lang] -> Bool) -> [[Lang]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Lang] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[[Lang]]]
values = Maybe Lang
forall a. Maybe a
Nothing
  | Bool
otherwise = Lang -> Maybe Lang
forall a. a -> Maybe a
Just (Lang -> Maybe Lang) -> Lang -> Maybe Lang
forall a b. (a -> b) -> a -> b
$ Lang -> [Lang] -> Lang
T.intercalate Lang
argDelimiter ([Lang] -> Lang) -> [Lang] -> Lang
forall a b. (a -> b) -> a -> b
$ ([[Lang]] -> Lang) -> [[[Lang]]] -> [Lang]
forall a b. (a -> b) -> [a] -> [b]
map ([Lang] -> Lang
process ([Lang] -> Lang) -> ([[Lang]] -> [Lang]) -> [[Lang]] -> Lang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Lang]] -> [Lang]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) [[[Lang]]]
values


toJSUnicode :: Char -> Text
toJSUnicode :: Char -> Lang
toJSUnicode Char
c
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isAscii Char
c = Lang
"\\u" Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Lang -> Lang
T.justifyRight Int
4 Char
'0' (String -> Lang
T.pack (String -> Lang) -> String -> Lang
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Integral a => a -> ShowS
showHex (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) String
"")
      | Bool
otherwise       = Char -> Lang
T.singleton Char
c



removeEscape :: Text -> [[Text]]
removeEscape :: Lang -> [[Lang]]
removeEscape Lang
t = (Lang -> Lang) -> [Lang] -> [Lang]
forall a b. (a -> b) -> [a] -> [b]
map (\Lang
i -> Lang -> Maybe Lang -> Lang
forall a. a -> Maybe a -> a
fromMaybe Lang
i (Maybe Lang -> Lang) -> Maybe Lang -> Lang
forall a b. (a -> b) -> a -> b
$ String -> Maybe Lang
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Lang) -> String -> Maybe Lang
forall a b. (a -> b) -> a -> b
$ Lang -> String
T.unpack (Lang -> String) -> Lang -> String
forall a b. (a -> b) -> a -> b
$ Int -> Lang -> Lang
T.drop Int
1 (Lang -> Lang) -> Lang -> Lang
forall a b. (a -> b) -> a -> b
$ Int -> Lang -> Lang
T.dropEnd Int
1 Lang
i) ([Lang] -> [Lang]) -> [[Lang]] -> [[Lang]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lang -> [[Lang]]
splitArgs Lang
t
  where
    splitArgs :: Lang -> [[Lang]]
splitArgs = (Lang -> [Lang]) -> [Lang] -> [[Lang]]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => Lang -> Lang -> [Lang]
Lang -> Lang -> [Lang]
T.splitOn Lang
listDelimiter) ([Lang] -> [[Lang]]) -> (Lang -> [Lang]) -> Lang -> [[Lang]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Lang -> Lang -> [Lang]
Lang -> Lang -> [Lang]
T.splitOn Lang
argDelimiter



asUnicode :: Text -> [Text]
asUnicode :: Lang -> [Lang]
asUnicode Lang
t = [Lang] -> Lang
compress ([Lang] -> Lang) -> ([Lang] -> [Lang]) -> [Lang] -> Lang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lang -> Lang) -> [Lang] -> [Lang]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Lang) -> Lang -> Lang
T.concatMap Char -> Lang
toJSUnicode) ([Lang] -> Lang) -> [[Lang]] -> [Lang]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lang -> [[Lang]]
removeEscape Lang
t
  where
    compress :: [Lang] -> Lang
compress [Lang]
x
      | [Lang] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Lang]
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = String -> Lang
T.pack (String -> Lang) -> String -> Lang
forall a b. (a -> b) -> a -> b
$ [Lang] -> String
forall a. Show a => a -> String
show [Lang]
x
      | [Lang]
x [Lang] -> [Lang] -> Bool
forall a. Eq a => a -> a -> Bool
== [Lang
""]    = Lang
T.empty
      | Bool
otherwise    = String -> Lang
T.pack (String -> Lang) -> String -> Lang
forall a b. (a -> b) -> a -> b
$ Lang -> String
forall a. Show a => a -> String
show (Lang -> String) -> Lang -> String
forall a b. (a -> b) -> a -> b
$ [Lang] -> Lang
T.concat [Lang]
x


correctUnicodeEscape :: Text -> Text
correctUnicodeEscape :: Lang -> Lang
correctUnicodeEscape = HasCallStack => Lang -> Lang -> Lang -> Lang
Lang -> Lang -> Lang -> Lang
T.replace Lang
"\\\\u" Lang
"\\u"



-- | Process Text containing Haskell Unicode representation for use in JavaScript.
formatForJS :: Text -> Text
formatForJS :: Lang -> Lang
formatForJS Lang
t = Lang
"[" Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> Lang -> Lang
correctUnicodeEscape (Lang -> [Lang] -> Lang
T.intercalate Lang
"," ([Lang] -> Lang) -> [Lang] -> Lang
forall a b. (a -> b) -> a -> b
$ Lang -> [Lang]
asUnicode Lang
t) Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> Lang
"]"



{- |
Remove excessive escape characters in front of Unicode
caused by conversion between Haskell and JavaScript representation.
-}
removeUnicodeEscape :: String -> String
removeUnicodeEscape :: ShowS
removeUnicodeEscape (Char
x:String
xs)
    | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Int
ident Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
127 Bool -> Bool -> Bool
&& Bool
inUnicodeRange
      = String
unicodeIdent String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
removeUnicodeEscape String
rest
    | Bool
otherwise = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
removeUnicodeEscape String
xs
  where
    (String
unicodeIdent,String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
xs
    ident :: Int
ident = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
unicodeIdent
    inUnicodeRange :: Bool
inUnicodeRange = Int
ident Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int
1114111 :: Int)
removeUnicodeEscape String
xs = String
xs



{- |
Create an exact duplicate of the given form data, but append all field names with a unique identifier.
This is used to render multiple views of the input form on the same page, e.g. the comments page in Autotool.
-}
uniqueFormCopy :: ([[Text]],Html) -> String -> ([[Text]],Html)
uniqueFormCopy :: ([[Lang]], Html) -> String -> ([[Lang]], Html)
uniqueFormCopy ([[Lang]]
params,Html
html) String
uniqueId = ([[Lang]]
newParams, Html
alteredHtml)
  where
    suffix :: String
suffix = Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: String
uniqueId
    newParams :: [[Lang]]
newParams = ([Lang] -> [Lang]) -> [[Lang]] -> [[Lang]]
forall a b. (a -> b) -> [a] -> [b]
map ((Lang -> Lang) -> [Lang] -> [Lang]
forall a b. (a -> b) -> [a] -> [b]
map (Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> String -> Lang
T.pack String
suffix)) [[Lang]]
params
    alteredHtml :: Html
alteredHtml = String -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ (Lang -> ShowS) -> String -> [Lang] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      ( (\String
param -> String -> String -> ShowS
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace (String
"name=\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
param String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\"") (String
"name=\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
param String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
suffix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\"")) (String -> ShowS) -> (Lang -> String) -> Lang -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Lang -> String
T.unpack
      )
      (Html -> String
renderHtml Html
html)
      ([Lang] -> String) -> [Lang] -> String
forall a b. (a -> b) -> a -> b
$ [[Lang]] -> [Lang]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Lang]]
params


{- |
Format an answer String into a vertical text listing of individual values.
This is used to display Flex submissions when using the "download all submission" feature in Autotool.
-}
formatIfFlexSubmission :: Text -> Text
formatIfFlexSubmission :: Lang -> Lang
formatIfFlexSubmission Lang
t
    | Bool -> Bool
not ( Lang
argDelimiter  Lang -> Lang -> Bool
`T.isInfixOf` Lang
t Bool -> Bool -> Bool
||
            Lang
listDelimiter Lang -> Lang -> Bool
`T.isInfixOf` Lang
t Bool -> Bool -> Bool
||
            Bool
escapeWrapped
          ) = Lang
t
    | [Lang] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Lang]
splitArgs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& [Lang] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Lang]
splitLists Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Lang -> Lang
stripEscape Lang
t
    | [Lang] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Lang]
splitArgs Bool -> Bool -> Bool
|| (Lang -> Bool) -> [Lang] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Lang -> Bool
T.null [Lang]
splitArgs = Lang
""
    | Bool
otherwise = [Lang] -> Lang
T.unlines [Lang]
numberInputs
    where
      escapeSeq :: Lang
escapeSeq = Lang
inputEscape Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> Lang
inputEscape
      escapeWrapped :: Bool
escapeWrapped = Lang
escapeSeq Lang -> Lang -> Bool
`T.isPrefixOf` Lang
t Bool -> Bool -> Bool
&& Lang
escapeSeq Lang -> Lang -> Bool
`T.isSuffixOf` Lang
t
      splitArgs :: [Lang]
splitArgs = HasCallStack => Lang -> Lang -> [Lang]
Lang -> Lang -> [Lang]
T.splitOn Lang
argDelimiter Lang
t
      splitLists :: [Lang]
splitLists = HasCallStack => Lang -> Lang -> [Lang]
Lang -> Lang -> [Lang]
T.splitOn Lang
listDelimiter Lang
t
      stripEscape :: Lang -> Lang
stripEscape = Lang -> Maybe Lang -> Lang
forall a. a -> Maybe a -> a
fromMaybe Lang
failureMessage (Maybe Lang -> Lang) -> (Lang -> Maybe Lang) -> Lang -> Lang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Lang
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Lang) -> (Lang -> String) -> Lang -> Maybe Lang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lang -> String
T.unpack (Lang -> String) -> (Lang -> Lang) -> Lang -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Lang -> Lang
T.drop Int
1 (Lang -> Lang) -> (Lang -> Lang) -> Lang -> Lang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Lang -> Lang
T.dropEnd Int
1
      unescaped :: [[Lang]]
unescaped = (Lang -> Lang) -> [Lang] -> [Lang]
forall a b. (a -> b) -> [a] -> [b]
map Lang -> Lang
stripEscape ([Lang] -> [Lang]) -> (Lang -> [Lang]) -> Lang -> [Lang]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Lang -> Lang -> [Lang]
Lang -> Lang -> [Lang]
T.splitOn Lang
listDelimiter (Lang -> [Lang]) -> [Lang] -> [[Lang]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Lang]
splitArgs
      fieldIndices :: [Lang]
fieldIndices = (Int -> Lang) -> [Int] -> [Lang]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Lang
"Field " Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> String -> Lang
T.pack (forall a. Show a => a -> String
show @Int Int
i) Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> Lang
": ") [Int
1..]
      numberInputs :: [Lang]
numberInputs = (Lang -> Lang -> Lang) -> [Lang] -> [Lang] -> [Lang]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
(<>) [Lang]
fieldIndices ([Lang] -> [Lang]) -> [Lang] -> [Lang]
forall a b. (a -> b) -> a -> b
$ ([Lang] -> Lang) -> [[Lang]] -> [Lang]
forall a b. (a -> b) -> [a] -> [b]
map (Lang -> [Lang] -> Lang
T.intercalate Lang
",") [[Lang]]
unescaped
      failureMessage :: Lang
failureMessage = Lang
"failed to format value for display"


-- | List of languages to cover for input form HTML in instances of `RenderMessage` for custom translations.
supportedLanguages :: [Lang]
supportedLanguages :: [Lang]
supportedLanguages = [Lang
"de",Lang
"en"]