1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
-- | 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 = Wrap 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 (Read,Show,Eq,Ord)
instance Default TextFormat where def = 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 = showString . showText defaultWrap
show x = showText defaultWrap [x]
-- | Show some text using the given formatting.
showText :: TextFormat -> [Text] -> String
showText HTML = showHTML
showText (Wrap x) = showWrap x
---------------------------------------------------------------------
-- TEXT OUTPUT
showWrap :: Int -> [Text] -> String
showWrap width xs = unlines $ concatMap f xs
where
cs :: [(Int,[Int])]
cs = map (\x -> (fst $ head x, map maximum $ transpose $ map snd x)) $
groupBy ((==) `on` fst) $ sortBy (compare `on` fst)
[(length x, map length $ init x) | Cols x <- xs]
pad n x = x ++ replicate (n - length x) ' '
f (Line x) = map (a++) $ wrap1 (width - length a) b
where (a,b) = span isSpace x
f (Cols xs) = concat (zipWith pad ys xs ++ [z1]) : map (replicate n ' '++) zs
where ys = fromJust $ lookup (length xs) cs
n = sum ys + length (takeWhile isSpace $ last xs)
z1:zs = wrap1 (width - n) (last xs)
wrap1 width x = ["" | null res] ++ res
where res = wrap width x
-- | Split the text into strips of no-more than the given width
wrap :: Int -> String -> [String]
wrap width = concatMap (combine . split) . lines
where
split :: String -> [(String,Int)] -- string, amount of space after
split "" = []
split x = (a,length c) : split d
where (a,b) = break isSpace x
(c,d) = span isSpace b
-- combine two adjacent chunks while they are less than width
combine :: [(String,Int)] -> [String]
combine ((a,b):(c,d):xs) | length a + b + length c < width = combine $ (a ++ replicate b ' ' ++ c,d):xs
combine (x:xs) = fst x : combine xs
combine [] = []
---------------------------------------------------------------------
-- HTML OUTPUT
showHTML :: [Text] -> String
showHTML xs = unlines $
["<table class='cmdargs'>"] ++
map f xs ++
["</table>"]
where
maxCols = maximum [length x | Cols x <- xs]
f (Line x) = tr $ td maxCols x
f (Cols xs) = tr $ concatMap (td 1) (init xs) ++ td (maxCols + 1 - length xs) (last xs)
tr x = "<tr>" ++ x ++ "</tr>"
td cols x = "<td" ++ (if cols == 1 then "" else " colspan='" ++ show cols ++ "'")
++ (if null styles then "" else " style='" ++ unwords styles ++ "'") ++
">" ++ if null b then " " else concatMap esc b ++ "</td>"
where (a,b) = span isSpace 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 = take 1 b == "-"
styles = [ "padding-left:" ++ show (length a) ++ "ex;" | a /= "" ]
++ [ "white-space:nowrap;" | isFlag ]
esc '&' = "&"
esc '>' = ">"
esc '<' = "<"
esc '\n' = "<br />"
esc x = [x]
|
