{-# 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
    -- * Internationalization
  , supportedLanguages
  ) where


import Data.Char                        (isAscii, isDigit)
import Data.Maybe                       (fromMaybe)
import Data.Text                        (Text)
import Numeric                          (showHex)
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
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]]
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
      | Bool
otherwise    = [Lang] -> Lang
T.concat [Lang]
x


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



-- | Process Text containing Haskell Unicode representation for use in JavaScript.
formatForJS :: Text -> Text
formatForJS :: Lang -> Lang
formatForJS Lang
t = Lang -> Lang
correctUnicodeEscape (Lang -> Lang) -> Lang -> Lang
forall a b. (a -> b) -> a -> b
$ 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]
asUnicode Lang
t



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



{- |
Format an answer String into a vertical text listing of individual values.
This is used to display Flex submissions in a non-HTML context, e.g. in a downloadable text file.
-}
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"]