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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
-- | Note: the core types and comibnators
-- from this module are from Toxaris in a #haskell
-- conversation on 2008-08-24
{-# LANGUAGE FlexibleContexts #-}
module Text.Tabular where
import Data.List (intersperse)
import Control.Monad.State (evalState, State, get, put)
data Properties = NoLine | SingleLine | DoubleLine
deriving (Show)
data Header h = Header h | Group Properties [Header h]
deriving (Show)
-- |
-- > example = Table
-- > (Group SingleLine
-- > [ Group NoLine [Header "A 1", Header "A 2"]
-- > , Group NoLine [Header "B 1", Header "B 2", Header "B 3"]
-- > ])
-- > (Group DoubleLine
-- > [ Group SingleLine [Header "memtest 1", Header "memtest 2"]
-- > , Group SingleLine [Header "time test 1", Header "time test 2"]
-- > ])
-- > [ ["hog", "terrible", "slow", "slower"]
-- > , ["pig", "not bad", "fast", "slowest"]
-- > , ["good", "awful" , "intolerable", "bearable"]
-- > , ["better", "no chance", "crawling", "amazing"]
-- > , ["meh", "well...", "worst ever", "ok"]
-- > ]
--
-- > -- Text.Tabular.AsciiArt.render id id id example
-- > --
-- > -- || memtest 1 | memtest 2 || time test | time test 2
-- > -- ====++===========+===========++=============+============
-- > -- A 1 || hog | terrible || slow | slower
-- > -- A 2 || pig | not bad || fast | slowest
-- > -- ----++-----------+-----------++-------------+------------
-- > -- B 1 || good | awful || intolerable | bearable
-- > -- B 2 || better | no chance || crawling | amazing
-- > -- B 3 || meh | well... || worst ever | ok
data Table rh ch a = Table (Header rh) (Header ch) [[a]]
deriving (Show)
-- ----------------------------------------------------------------------
-- * Helper functions for rendering
-- ----------------------------------------------------------------------
-- | Retrieve the contents of a header
headerContents :: Header h -> [h]
headerContents (Header s) = [s]
headerContents (Group _ hs) = concatMap headerContents hs
instance Functor Header where
fmap f (Header s) = Header (f s)
fmap f (Group p hs) = Group p (map (fmap f) hs)
-- | 'zipHeader' @e@ @ss@ @h@ returns the same structure
-- as @h@ except with all the text replaced by the contents
-- of @ss@.
--
-- If @ss@ has too many cells, the excess is ignored.
-- If it has too few cells, the missing ones (at the end)
-- and replaced with the empty contents @e@
zipHeader :: h -> [h] -> Header a -> Header (h,a)
zipHeader e ss h = evalState (helper h) ss
where
helper (Header x) =
do cells <- get
string <- case cells of
[] -> return (e,x)
(s:ss) -> put ss >> return (s,x)
return $ Header string
helper (Group s hs) =
Group s `fmap` mapM helper hs
flattenHeader :: Header h -> [Either Properties h]
flattenHeader (Header s) = [Right s]
flattenHeader (Group l s) =
concat . intersperse [Left l] . map flattenHeader $ s
-- | The idea is to deal with the fact that Properties
-- (e.g. borders) are not standalone cells but attributes
-- of a cell. A border is just a CSS decoration of a
-- TD element.
--
-- squish @decorator f h@ applies @f@ to every item
-- in the list represented by @h@ (see 'flattenHeader'),
-- additionally applying @decorator@ if the item is
-- followed by some kind of boundary
--
-- So
-- @
-- o o o | o o o | o o
-- @
-- gets converted into
-- @
-- O O X O O X O O
-- @
squish :: (Properties -> b -> b)
-> (h -> b)
-> Header h
-> [b]
squish decorator f h = helper $ flattenHeader h
where
helper [] = []
helper (Left p:es) = helper es
helper (Right x:es) =
case es of
(Left p:es2) -> decorator p (f x) : helper es2
_ -> f x : helper es
-- ----------------------------------------------------------------------
-- * Combinators
-- ----------------------------------------------------------------------
-- | Convenience type for just one row (or column).
-- To be used with combinators as follows:
--
-- > example2 =
-- > empty ^..^ col "memtest 1" [] ^|^ col "memtest 2" []
-- > ^||^ col "time test "[] ^|^ col "time test 2" []
-- > +.+ row "A 1" ["hog", "terrible", "slow", "slower"]
-- > +.+ row "A 2" ["pig", "not bad", "fast", "slowest"]
-- > +----+
-- > row "B 1" ["good", "awful", "intolerable", "bearable"]
-- > +.+ row "B 2" ["better", "no chance", "crawling", "amazing"]
-- > +.+ row "B 3" ["meh", "well...", "worst ever", "ok"]
data SemiTable h a = SemiTable (Header h) [a]
deriving (Show)
empty :: Table rh ch a
empty = Table (Group NoLine []) (Group NoLine []) []
col :: ch -> [a] -> SemiTable ch a
col header cells = SemiTable (Header header) cells
-- | Column header
colH :: ch -> SemiTable ch a
colH header = col header []
row :: rh -> [a] -> SemiTable rh a
row = col
rowH :: rh -> SemiTable rh a
rowH = colH
beside :: Properties -> Table rh ch a -> SemiTable ch a -> Table rh ch a
beside prop (Table rows cols1 data1)
(SemiTable cols2 data2) =
Table rows (Group prop [cols1, cols2])
(zipWith (\xs x -> xs ++ [x]) data1 data2)
below :: Properties -> Table rh ch a -> SemiTable rh a -> Table rh ch a
below prop (Table rows1 cols data1)
(SemiTable rows2 data2) =
Table (Group prop [rows1, rows2]) cols (data1 ++ [data2])
-- | besides
(^..^) :: Table rh ch a -> SemiTable ch a -> Table rh ch a
(^..^) = beside NoLine
-- | besides with a line
(^|^) :: Table rh ch a -> SemiTable ch a -> Table rh ch a
(^|^) = beside SingleLine
-- | besides with a double line
(^||^) :: Table rh ch a -> SemiTable ch a -> Table rh ch a
(^||^) = beside DoubleLine
-- | below
(+.+) :: Table rh ch a -> SemiTable rh a -> Table rh ch a
(+.+) = below NoLine
-- | below with a line
(+----+) :: Table rh ch a -> SemiTable rh a -> Table rh ch a
(+----+) = below SingleLine
-- | below with a double line
(+====+) :: Table rh ch a -> SemiTable rh a -> Table rh ch a
(+====+) = below DoubleLine
|
