-- | Text formatting helpers, ported from String as needed.
-- There may be better alternatives out there.

{-# LANGUAGE OverloadedStrings #-}

module Hledger.Utils.Text
  (
  -- * misc
  -- lowercase,
  -- uppercase,
  -- underline,
  -- stripbrackets,
  textUnbracket,
  wrap,
  textChomp,
  -- quoting
  quoteIfSpaced,
  textQuoteIfNeeded,
  -- singleQuoteIfNeeded,
  -- quotechars,
  -- whitespacechars,
  escapeDoubleQuotes,
  -- escapeSingleQuotes,
  -- escapeQuotes,
  -- words',
  -- unwords',
  stripquotes,
  -- isSingleQuoted,
  -- isDoubleQuoted,
  -- * single-line layout
  -- elideLeft,
  textElideRight,
  formatText,
  -- * multi-line layout
  textConcatTopPadded,
  textConcatBottomPadded,
  fitText,
  linesPrepend,
  linesPrepend2,
  unlinesB,
  -- * wide-character-aware layout
  WideBuilder(..),
  wbToText,
  wbFromText,
  wbUnpack,
  textTakeWidth,
  -- * Reading
  readDecimal,
  -- * tests
  tests_Text
  )
where

import Data.Char (digitToInt)
import Data.Default (def)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import Text.DocLayout (charWidth, realLength)

import Test.Tasty (testGroup)
import Test.Tasty.HUnit ((@?=), testCase)
import Text.Tabular.AsciiWide
  (Align(..), Header(..), Properties(..), TableOpts(..), renderRow, textCell)
import Text.WideString (WideBuilder(..), wbToText, wbFromText, wbUnpack)


-- lowercase, uppercase :: String -> String
-- lowercase = map toLower
-- uppercase = map toUpper

-- stripbrackets :: String -> String
-- stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String

-- elideLeft :: Int -> String -> String
-- elideLeft width s =
--     if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s

textElideRight :: Int -> Text -> Text
textElideRight :: Int -> Text -> Text
textElideRight Int
width Text
t =
    if Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
width then Int -> Text -> Text
T.take (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".." else Text
t

-- | Wrap a Text with the surrounding Text.
wrap :: Text -> Text -> Text -> Text
wrap :: Text -> Text -> Text -> Text
wrap Text
start Text
end Text
x = Text
start Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end

-- | Remove trailing newlines/carriage returns.
textChomp :: Text -> Text
textChomp :: Text -> Text
textChomp = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\r', Char
'\n'])

-- | Clip and pad a string to a minimum & maximum width, and/or left/right justify it.
-- Works on multi-line strings too (but will rewrite non-unix line endings).
formatText :: Bool -> Maybe Int -> Maybe Int -> Text -> Text
formatText :: Bool -> Maybe Int -> Maybe Int -> Text -> Text
formatText Bool
leftJustified Maybe Int
minwidth Maybe Int
maxwidth Text
t =
    Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
pad (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
clip) ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ if Text -> Bool
T.null Text
t then [Text
""] else Text -> [Text]
T.lines Text
t
  where
    pad :: Text -> Text
pad  = (Text -> Text)
-> (Int -> Text -> Text) -> Maybe Int -> Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text -> Text
forall a. a -> a
id Int -> Text -> Text
justify Maybe Int
minwidth
    clip :: Text -> Text
clip = (Text -> Text)
-> (Int -> Text -> Text) -> Maybe Int -> Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text -> Text
forall a. a -> a
id Int -> Text -> Text
T.take Maybe Int
maxwidth
    justify :: Int -> Text -> Text
justify Int
n = if Bool
leftJustified then Int -> Char -> Text -> Text
T.justifyLeft Int
n Char
' ' else Int -> Char -> Text -> Text
T.justifyRight Int
n Char
' '

-- underline :: String -> String
-- underline s = s' ++ replicate (length s) '-' ++ "\n"
--     where s'
--             | last s == '\n' = s
--             | otherwise = s ++ "\n"

-- | Wrap a string in double quotes, and \-prefix any embedded single
-- quotes, if it contains whitespace and is not already single- or
-- double-quoted.
quoteIfSpaced :: T.Text -> T.Text
quoteIfSpaced :: Text -> Text
quoteIfSpaced Text
s | Text -> Bool
isSingleQuoted Text
s Bool -> Bool -> Bool
|| Text -> Bool
isDoubleQuoted Text
s = Text
s
                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c) Text
s) [Char]
whitespacechars = Text
s
                | Bool
otherwise = Text -> Text
textQuoteIfNeeded Text
s

-- -- | Wrap a string in double quotes, and \-prefix any embedded single
-- -- quotes, if it contains whitespace and is not already single- or
-- -- double-quoted.
-- quoteIfSpaced :: String -> String
-- quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s
--                 | not $ any (`elem` s) whitespacechars = s
--                 | otherwise = "'"++escapeSingleQuotes s++"'"

-- -- | Double-quote this string if it contains whitespace, single quotes
-- -- or double-quotes, escaping the quotes as needed.
textQuoteIfNeeded :: T.Text -> T.Text
textQuoteIfNeeded :: Text -> Text
textQuoteIfNeeded Text
s | (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c) Text
s) ([Char]
quotechars[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
whitespacechars) = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeDoubleQuotes Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
                    | Bool
otherwise = Text
s

-- -- | Single-quote this string if it contains whitespace or double-quotes.
-- -- No good for strings containing single quotes.
-- singleQuoteIfNeeded :: String -> String
-- singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"
--                       | otherwise = s

quotechars, whitespacechars :: [Char]
quotechars :: [Char]
quotechars      = [Char]
"'\""
whitespacechars :: [Char]
whitespacechars = [Char]
" \t\n\r"

escapeDoubleQuotes :: T.Text -> T.Text
escapeDoubleQuotes :: Text -> Text
escapeDoubleQuotes = Text -> Text -> Text -> Text
T.replace Text
"\"" Text
"\\\""

-- escapeSingleQuotes :: T.Text -> T.Text
-- escapeSingleQuotes = T.replace "'" "\'"

-- escapeQuotes :: String -> String
-- escapeQuotes = regexReplace "([\"'])" "\\1"

-- -- | Quote-aware version of words - don't split on spaces which are inside quotes.
-- -- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails.
-- words' :: String -> [String]
-- words' "" = []
-- words' s  = map stripquotes $ fromparse $ parsewith p s
--     where
--       p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline
--              -- eof
--              return ss
--       pattern = many (noneOf whitespacechars)
--       singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'")
--       doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"")

-- -- | Quote-aware version of unwords - single-quote strings which contain whitespace
-- unwords' :: [Text] -> Text
-- unwords' = T.unwords . map quoteIfNeeded

-- | Strip one matching pair of single or double quotes on the ends of a string.
stripquotes :: Text -> Text
stripquotes :: Text -> Text
stripquotes Text
s = if Text -> Bool
isSingleQuoted Text
s Bool -> Bool -> Bool
|| Text -> Bool
isDoubleQuoted Text
s then Text -> Text
T.init (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail Text
s else Text
s

isSingleQuoted :: Text -> Bool
isSingleQuoted :: Text -> Bool
isSingleQuoted Text
s =
  Text -> Int
T.length Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Text -> Char
T.head Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
&& Text -> Char
T.last Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

isDoubleQuoted :: Text -> Bool
isDoubleQuoted :: Text -> Bool
isDoubleQuoted Text
s =
  Text -> Int
T.length Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Text -> Char
T.head Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
&& Text -> Char
T.last Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"'

textUnbracket :: Text -> Text
textUnbracket :: Text -> Text
textUnbracket Text
s
    | Text -> Bool
T.null Text
s = Text
s
    | Text -> Char
T.head Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[' Bool -> Bool -> Bool
&& Text -> Char
T.last Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
']' = Text -> Text
T.init (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail Text
s
    | Text -> Char
T.head Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& Text -> Char
T.last Text
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' = Text -> Text
T.init (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail Text
s
    | Bool
otherwise = Text
s

-- | Join several multi-line strings as side-by-side rectangular strings of the same height, top-padded.
-- Treats wide characters as double width.
textConcatTopPadded :: [Text] -> Text
textConcatTopPadded :: [Text] -> Text
textConcatTopPadded = Text -> Text
TL.toStrict (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableOpts -> Header Cell -> Text
renderRow TableOpts
forall a. Default a => a
def{tableBorders :: Bool
tableBorders=Bool
False, borderSpaces :: Bool
borderSpaces=Bool
False}
                    (Header Cell -> Text) -> ([Text] -> Header Cell) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Properties -> [Header Cell] -> Header Cell
forall h. Properties -> [Header h] -> Header h
Group Properties
NoLine ([Header Cell] -> Header Cell)
-> ([Text] -> [Header Cell]) -> [Text] -> Header Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Header Cell) -> [Text] -> [Header Cell]
forall a b. (a -> b) -> [a] -> [b]
map (Cell -> Header Cell
forall h. h -> Header h
Header (Cell -> Header Cell) -> (Text -> Cell) -> Text -> Header Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Align -> Text -> Cell
textCell Align
BottomLeft)

-- | Join several multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.
-- Treats wide characters as double width.
textConcatBottomPadded :: [Text] -> Text
textConcatBottomPadded :: [Text] -> Text
textConcatBottomPadded = Text -> Text
TL.toStrict (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableOpts -> Header Cell -> Text
renderRow TableOpts
forall a. Default a => a
def{tableBorders :: Bool
tableBorders=Bool
False, borderSpaces :: Bool
borderSpaces=Bool
False}
                       (Header Cell -> Text) -> ([Text] -> Header Cell) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Properties -> [Header Cell] -> Header Cell
forall h. Properties -> [Header h] -> Header h
Group Properties
NoLine ([Header Cell] -> Header Cell)
-> ([Text] -> [Header Cell]) -> [Text] -> Header Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Header Cell) -> [Text] -> [Header Cell]
forall a b. (a -> b) -> [a] -> [b]
map (Cell -> Header Cell
forall h. h -> Header h
Header (Cell -> Header Cell) -> (Text -> Cell) -> Text -> Header Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Align -> Text -> Cell
textCell Align
TopLeft)

-- -- Functions below treat wide (eg CJK) characters as double-width.

-- | General-purpose wide-char-aware single-line text layout function.
-- It can left- or right-pad a short string to a minimum width.
-- It can left- or right-clip a long string to a maximum width, optionally inserting an ellipsis (the third argument).
-- It clips and pads on the right when the fourth argument is true, otherwise on the left.
-- It treats wide characters as double width.
fitText :: Maybe Int -> Maybe Int -> Bool -> Bool -> Text -> Text
fitText :: Maybe Int -> Maybe Int -> Bool -> Bool -> Text -> Text
fitText Maybe Int
mminwidth Maybe Int
mmaxwidth Bool
ellipsify Bool
rightside = Text -> Text
clip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
pad
  where
    clip :: Text -> Text
    clip :: Text -> Text
clip Text
s =
      case Maybe Int
mmaxwidth of
        Just Int
w
          | Text -> Int
forall a. HasChars a => a -> Int
realLength Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
w ->
            if Bool
rightside
              then Int -> Text -> Text
textTakeWidth (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
ellipsis) Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ellipsis
              else Text
ellipsis Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.reverse (Int -> Text -> Text
textTakeWidth (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
ellipsis) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.reverse Text
s)
          | Bool
otherwise -> Text
s
          where
            ellipsis :: Text
ellipsis = if Bool
ellipsify then Text
".." else Text
""
        Maybe Int
Nothing -> Text
s
    pad :: Text -> Text
    pad :: Text -> Text
pad Text
s =
      case Maybe Int
mminwidth of
        Just Int
w
          | Int
sw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w ->
            if Bool
rightside
              then Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sw) Text
" "
              else Int -> Text -> Text
T.replicate (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sw) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
          | Bool
otherwise -> Text
s
        Maybe Int
Nothing -> Text
s
      where sw :: Int
sw = Text -> Int
forall a. HasChars a => a -> Int
realLength Text
s

-- | Double-width-character-aware string truncation. Take as many
-- characters as possible from a string without exceeding the
-- specified width. Eg textTakeWidth 3 "りんご" = "り".
textTakeWidth :: Int -> Text -> Text
textTakeWidth :: Int -> Text -> Text
textTakeWidth Int
_ Text
""     = Text
""
textTakeWidth Int
0 Text
_      = Text
""
textTakeWidth Int
w Text
t | Bool -> Bool
not (Text -> Bool
T.null Text
t),
                let c :: Char
c = Text -> Char
T.head Text
t,
                let cw :: Int
cw = Char -> Int
charWidth Char
c,
                Int
cw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
w
                = Char -> Text -> Text
T.cons Char
c (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
textTakeWidth (Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
cw) (Text -> Text
T.tail Text
t)
              | Bool
otherwise = Text
""

-- | Add a prefix to each line of a string.
linesPrepend :: Text -> Text -> Text
linesPrepend :: Text -> Text -> Text
linesPrepend Text
prefix = [Text] -> Text
T.unlines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
prefixText -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

-- | Add a prefix to the first line of a string, 
-- and a different prefix to the remaining lines.
linesPrepend2 :: Text -> Text -> Text -> Text
linesPrepend2 :: Text -> Text -> Text -> Text
linesPrepend2 Text
prefix1 Text
prefix2 Text
s = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ case Text -> [Text]
T.lines Text
s of
    []   -> []
    Text
l:[Text]
ls -> (Text
prefix1Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
l) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
prefix2Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
ls

-- | Join a list of Text Builders with a newline after each item.
unlinesB :: [TB.Builder] -> TB.Builder
unlinesB :: [Builder] -> Builder
unlinesB = (Builder -> Builder) -> [Builder] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
'\n')

-- | Read a decimal number from a Text. Assumes the input consists only of digit
-- characters.
readDecimal :: Text -> Integer
readDecimal :: Text -> Integer
readDecimal = (Integer -> Char -> Integer) -> Integer -> Text -> Integer
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' Integer -> Char -> Integer
step Integer
0
  where step :: Integer -> Char -> Integer
step Integer
a Char
c = Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Char -> Int
digitToInt Char
c)


tests_Text :: TestTree
tests_Text = [Char] -> [TestTree] -> TestTree
testGroup [Char]
"Text" [
   [Char] -> Assertion -> TestTree
testCase [Char]
"quoteIfSpaced" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
     Text -> Text
quoteIfSpaced Text
"a'a" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"a'a"
     Text -> Text
quoteIfSpaced Text
"a\"a" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"a\"a"
     Text -> Text
quoteIfSpaced Text
"a a" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"\"a a\""
     Text -> Text
quoteIfSpaced Text
"mimi's cafe" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"\"mimi's cafe\""
     Text -> Text
quoteIfSpaced Text
"\"alex\" cafe" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"\"\\\"alex\\\" cafe\""
     Text -> Text
quoteIfSpaced Text
"le'shan's cafe" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"\"le'shan's cafe\""
     Text -> Text
quoteIfSpaced Text
"\"be'any's\" cafe" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"\"\\\"be'any's\\\" cafe\""
  ]