-- | A module to represent text with very basic formatting. Values are of
--   type ['Text'] and shown with 'showText'.
--
--   As an example of the formatting:
--
-- > [Line "Cooking for hungry people."
-- > ,Line "Welcome to my cookery recipe program, I sure hope you enjoy using it!"
-- > ,Line ""
-- > ,Cols ["Omlette","  A tasty eggy treat."]
-- > ,Cols ["  -m"," --mushrooms","  Some mushrooms, or in fact any other ingredients you have in the cupboards"]
-- > ,Cols ["  -e"," --eggs", "  But always you need eggs"]
-- > ,Line ""
-- > ,Cols ["Spagetti Bolognaise", "  An Italian delight."]
-- > ,Cols ["  -s"," --spagetti","  The first word in the name"]
-- > ,Cols ["  -b"," --bolognaise","  The second word in the name"]
-- > ,Cols ["  -d"," --dolmio","  The magic ingredient!"]
-- > ,Line ""
-- > ,Line "    The author of this program explicitly disclaims any liability for poisoning people who get their recipes off the internet."]
--
--   With @putStrLn ('showText' ('Wrap' 50) demo)@ gives:
--
-- > Cooking for hungry people.
-- > Welcome to my cookery recipe program, I sure hope
-- > you enjoy using it!
-- >
-- > Omlette              A tasty eggy treat.
-- >   -m --mushrooms   Some mushrooms, or in fact
-- >                    any other ingredients you have
-- >                    in the cupboards
-- >   -e --eggs        But always you need eggs
-- >
-- > Spagetti Bolognaise  An Italian delight.
-- >   -s --spagetti    The first word in the name
-- >   -b --bolognaise  The second word in the name
-- >   -d --dolmio      The magic ingredient!
-- >
-- >     The author of this program explicitly
-- >     disclaims any liability for poisoning people
-- >     who get their recipes off the internet.
module System.Console.CmdArgs.Text(TextFormat(..), defaultWrap, Text(..), showText) where

import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import System.Console.CmdArgs.Default


-- | Wrap with the default width of 80 characters.
defaultWrap :: TextFormat
defaultWrap :: TextFormat
defaultWrap = Int -> TextFormat
Wrap Int
80

-- | How to output the text.
data TextFormat = HTML -- ^ Display as HTML.
                | Wrap Int -- ^ Display as text wrapped at a certain width (see 'defaultWrap').
                  deriving (ReadPrec [TextFormat]
ReadPrec TextFormat
Int -> ReadS TextFormat
ReadS [TextFormat]
(Int -> ReadS TextFormat)
-> ReadS [TextFormat]
-> ReadPrec TextFormat
-> ReadPrec [TextFormat]
-> Read TextFormat
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TextFormat]
$creadListPrec :: ReadPrec [TextFormat]
readPrec :: ReadPrec TextFormat
$creadPrec :: ReadPrec TextFormat
readList :: ReadS [TextFormat]
$creadList :: ReadS [TextFormat]
readsPrec :: Int -> ReadS TextFormat
$creadsPrec :: Int -> ReadS TextFormat
Read,Int -> TextFormat -> ShowS
[TextFormat] -> ShowS
TextFormat -> String
(Int -> TextFormat -> ShowS)
-> (TextFormat -> String)
-> ([TextFormat] -> ShowS)
-> Show TextFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextFormat] -> ShowS
$cshowList :: [TextFormat] -> ShowS
show :: TextFormat -> String
$cshow :: TextFormat -> String
showsPrec :: Int -> TextFormat -> ShowS
$cshowsPrec :: Int -> TextFormat -> ShowS
Show,TextFormat -> TextFormat -> Bool
(TextFormat -> TextFormat -> Bool)
-> (TextFormat -> TextFormat -> Bool) -> Eq TextFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextFormat -> TextFormat -> Bool
$c/= :: TextFormat -> TextFormat -> Bool
== :: TextFormat -> TextFormat -> Bool
$c== :: TextFormat -> TextFormat -> Bool
Eq,Eq TextFormat
Eq TextFormat
-> (TextFormat -> TextFormat -> Ordering)
-> (TextFormat -> TextFormat -> Bool)
-> (TextFormat -> TextFormat -> Bool)
-> (TextFormat -> TextFormat -> Bool)
-> (TextFormat -> TextFormat -> Bool)
-> (TextFormat -> TextFormat -> TextFormat)
-> (TextFormat -> TextFormat -> TextFormat)
-> Ord TextFormat
TextFormat -> TextFormat -> Bool
TextFormat -> TextFormat -> Ordering
TextFormat -> TextFormat -> TextFormat
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TextFormat -> TextFormat -> TextFormat
$cmin :: TextFormat -> TextFormat -> TextFormat
max :: TextFormat -> TextFormat -> TextFormat
$cmax :: TextFormat -> TextFormat -> TextFormat
>= :: TextFormat -> TextFormat -> Bool
$c>= :: TextFormat -> TextFormat -> Bool
> :: TextFormat -> TextFormat -> Bool
$c> :: TextFormat -> TextFormat -> Bool
<= :: TextFormat -> TextFormat -> Bool
$c<= :: TextFormat -> TextFormat -> Bool
< :: TextFormat -> TextFormat -> Bool
$c< :: TextFormat -> TextFormat -> Bool
compare :: TextFormat -> TextFormat -> Ordering
$ccompare :: TextFormat -> TextFormat -> Ordering
$cp1Ord :: Eq TextFormat
Ord)

instance Default TextFormat where def :: TextFormat
def = TextFormat
defaultWrap

-- | The data type representing some text, typically used as @[Text]@. The formatting
--   is described by:
--
--   * 'Line' values represent a paragraph of text, and may be wrapped depending on the 'TextFormat'.
--     If a 'Line' value is wrapped then all leading space will be treated as an indent.
--
--   * 'Cols' values represent columns of text. Within any @[Text]@ all columns of the same length
--     are grouped in tabs, with the final column being wrapped if necessary. All columns are placed
--     adjacent with no space between them - for this reason most columns will start with a space.
data Text = Line String -- a single line
          | Cols [String] -- a single line with columns (always indented by 2 spaces)

instance Show Text where
    showList :: [Text] -> ShowS
showList = String -> ShowS
showString (String -> ShowS) -> ([Text] -> String) -> [Text] -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextFormat -> [Text] -> String
showText TextFormat
defaultWrap
    show :: Text -> String
show Text
x = TextFormat -> [Text] -> String
showText TextFormat
defaultWrap [Text
x]


-- | Show some text using the given formatting.
showText :: TextFormat -> [Text] -> String
showText :: TextFormat -> [Text] -> String
showText TextFormat
HTML = [Text] -> String
showHTML
showText (Wrap Int
x) = Int -> [Text] -> String
showWrap Int
x


---------------------------------------------------------------------
-- TEXT OUTPUT

showWrap :: Int -> [Text] -> String
showWrap :: Int -> [Text] -> String
showWrap Int
width [Text]
xs = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Text -> [String]) -> [Text] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [String]
f [Text]
xs
    where
        cs :: [(Int,[Int])]
        cs :: [(Int, [Int])]
cs = ([(Int, [Int])] -> (Int, [Int]))
-> [[(Int, [Int])]] -> [(Int, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map (\[(Int, [Int])]
x -> ((Int, [Int]) -> Int
forall a b. (a, b) -> a
fst ((Int, [Int]) -> Int) -> (Int, [Int]) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, [Int])] -> (Int, [Int])
forall a. [a] -> a
head [(Int, [Int])]
x, ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[Int]] -> [[Int]]
forall a. [[a]] -> [[a]]
transpose ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ ((Int, [Int]) -> [Int]) -> [(Int, [Int])] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [Int]) -> [Int]
forall a b. (a, b) -> b
snd [(Int, [Int])]
x)) ([[(Int, [Int])]] -> [(Int, [Int])])
-> [[(Int, [Int])]] -> [(Int, [Int])]
forall a b. (a -> b) -> a -> b
$
                ((Int, [Int]) -> (Int, [Int]) -> Bool)
-> [(Int, [Int])] -> [[(Int, [Int])]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> ((Int, [Int]) -> Int) -> (Int, [Int]) -> (Int, [Int]) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, [Int]) -> Int
forall a b. (a, b) -> a
fst) ([(Int, [Int])] -> [[(Int, [Int])]])
-> [(Int, [Int])] -> [[(Int, [Int])]]
forall a b. (a -> b) -> a -> b
$ ((Int, [Int]) -> (Int, [Int]) -> Ordering)
-> [(Int, [Int])] -> [(Int, [Int])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, [Int]) -> Int)
-> (Int, [Int])
-> (Int, [Int])
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, [Int]) -> Int
forall a b. (a, b) -> a
fst)
                [([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
x, (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> [Int]) -> [String] -> [Int]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
init [String]
x) | Cols [String]
x <- [Text]
xs]
        pad :: Int -> ShowS
pad Int
n String
x = String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x) Char
' '

        f :: Text -> [String]
f (Line String
x) = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
aString -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
wrap1 (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
a) String
b
            where (String
a,String
b) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSpace String
x

        f (Cols [String]
xs) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Int -> ShowS) -> [Int] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ShowS
pad [Int]
ys [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
z1]) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' 'String -> ShowS
forall a. [a] -> [a] -> [a]
++) [String]
zs
            where ys :: [Int]
ys = Maybe [Int] -> [Int]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Int] -> [Int]) -> Maybe [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, [Int])] -> Maybe [Int]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs) [(Int, [Int])]
cs
                  n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
ys Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSpace ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
last [String]
xs)
                  String
z1:[String]
zs = Int -> String -> [String]
wrap1 (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) ([String] -> String
forall a. [a] -> a
last [String]
xs)


wrap1 :: Int -> String -> [String]
wrap1 Int
width String
x = [String
"" | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
res] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
res
    where res :: [String]
res = Int -> String -> [String]
wrap Int
width String
x

-- | Split the text into strips of no-more than the given width
wrap :: Int -> String -> [String]
wrap :: Int -> String -> [String]
wrap Int
width = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(String, Int)] -> [String]
combine ([(String, Int)] -> [String])
-> (String -> [(String, Int)]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, Int)]
split) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    where
        split :: String -> [(String,Int)] -- string, amount of space after
        split :: String -> [(String, Int)]
split String
"" = []
        split String
x = (String
a,String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c) (String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
: String -> [(String, Int)]
split String
d
            where (String
a,String
b) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
x
                  (String
c,String
d) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSpace String
b

        -- combine two adjacent chunks while they are less than width
        combine :: [(String,Int)] -> [String]
        combine :: [(String, Int)] -> [String]
combine ((String
a,Int
b):(String
c,Int
d):[(String, Int)]
xs) | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
width = [(String, Int)] -> [String]
combine ([(String, Int)] -> [String]) -> [(String, Int)] -> [String]
forall a b. (a -> b) -> a -> b
$ (String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
b Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
c,Int
d)(String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
:[(String, Int)]
xs
        combine ((String, Int)
x:[(String, Int)]
xs) = (String, Int) -> String
forall a b. (a, b) -> a
fst (String, Int)
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [(String, Int)] -> [String]
combine [(String, Int)]
xs
        combine [] = []


---------------------------------------------------------------------
-- HTML OUTPUT

showHTML :: [Text] -> String
showHTML :: [Text] -> String
showHTML [Text]
xs = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [String
"<table class='cmdargs'>"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
f [Text]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [String
"</table>"]
    where
        maxCols :: Int
maxCols = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [[String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
x | Cols [String]
x <- [Text]
xs]

        f :: Text -> String
f (Line String
x) = ShowS
tr ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. (Eq a, Num a, Show a) => a -> ShowS
td Int
maxCols String
x
        f (Cols [String]
xs) = ShowS
tr ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Integer -> ShowS
forall a. (Eq a, Num a, Show a) => a -> ShowS
td Integer
1) ([String] -> [String]
forall a. [a] -> [a]
init [String]
xs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. (Eq a, Num a, Show a) => a -> ShowS
td (Int
maxCols Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs) ([String] -> String
forall a. [a] -> a
last [String]
xs)

        tr :: ShowS
tr String
x = String
"<tr>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"</tr>"
        td :: a -> ShowS
td a
cols String
x = String
"<td" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if a
cols a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 then String
"" else String
" colspan='" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
cols String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'")
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
styles then String
"" else String
" style='" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
styles String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'") String -> ShowS
forall a. [a] -> [a] -> [a]
++
                     String
">" String -> ShowS
forall a. [a] -> [a] -> [a]
++ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b then String
"&nbsp;" else (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
esc String
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"</td>"
            where (String
a,String
b) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSpace String
x
                  -- if the first letter of the contents is '-', assume this is a flag
                  -- and be aware that HTML might try to line-break it, see #39
                  isFlag :: Bool
isFlag = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
1 String
b String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-"
                  styles :: [String]
styles = [ String
"padding-left:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"ex;" | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"" ]
                        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"white-space:nowrap;" | Bool
isFlag ]

        esc :: Char -> String
esc Char
'&' = String
"&amp;"
        esc Char
'>' = String
"&gt;"
        esc Char
'<' = String
"&lt;"
        esc Char
'\n' = String
"<br />"
        esc Char
x = [Char
x]