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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-- |
-- Module : Data.XCB.Pretty
-- Copyright : (c) Antoine Latter 2008
-- License : BSD3
--
-- Maintainer: Antoine Latter <aslatter@gmail.com>
-- Stability : provisional
-- Portability: portable - requires TypeSynonymInstances
--
-- Pretty-printers for the tyes declared in this package.
-- This does NOT ouput XML - it produces human-readable information
-- intended to aid in debugging.
module Data.XCB.Pretty where
import Data.XCB.Types
import Text.PrettyPrint.HughesPJ
import qualified Data.Map as Map
import Data.Maybe
-- |Minimal complete definition:
--
-- One of 'pretty' or 'toDoc'.
class Pretty a where
toDoc :: a -> Doc
pretty :: a -> String
pretty = show . toDoc
toDoc = text . pretty
-- Builtin types
instance Pretty String where
pretty = show
instance Pretty Int where
pretty = show
instance Pretty a => Pretty (Maybe a) where
toDoc Nothing = empty
toDoc (Just a) = toDoc a
pretty Nothing = ""
pretty (Just a) = pretty a
-- Simple stuff
instance Pretty a => Pretty (GenXidUnionElem a) where
toDoc (XidUnionElem t) = toDoc t
instance Pretty Binop where
pretty Add = "+"
pretty Sub = "-"
pretty Mult = "*"
pretty Div = "/"
pretty RShift = ">>"
pretty And = "&"
instance Pretty Unop where
pretty Complement = "~"
instance Pretty a => Pretty (EnumElem a) where
toDoc (EnumElem name expr)
= text name <> char ':' <+> toDoc expr
instance Pretty Type where
toDoc (UnQualType name) = text name
toDoc (QualType modifier name)
= text modifier <> char '.' <> text name
-- More complex stuff
instance Pretty a => Pretty (Expression a) where
toDoc (Value n) = toDoc n
toDoc (Bit n) = text "2^" <> toDoc n
toDoc (FieldRef ref) = char '$' <> text ref
toDoc (EnumRef typ child)
= toDoc typ <> char '.' <> text child
toDoc (PopCount expr)
= text "popcount" <> parens (toDoc expr)
toDoc (SumOf ref)
= text "sumof" <> (parens $ char '$' <> text ref)
toDoc (Op binop exprL exprR)
= parens $ hsep [toDoc exprL
,toDoc binop
,toDoc exprR
]
toDoc (Unop op expr)
= parens $ toDoc op <> toDoc expr
instance Pretty a => Pretty (GenStructElem a) where
toDoc (Pad n) = braces $ toDoc n <+> text "bytes"
toDoc (List nm typ len enums)
= text nm <+> text "::" <+> brackets (toDoc typ <+> toDoc enums) <+> toDoc len
toDoc (SField nm typ enums mask) = hsep [text nm
,text "::"
,toDoc typ
,toDoc enums
,toDoc mask
]
toDoc (ExprField nm typ expr)
= parens (text nm <+> text "::" <+> toDoc typ)
<+> toDoc expr
toDoc (Switch name expr cases)
= vcat
[ text "switch" <> parens (toDoc expr) <> brackets (text name)
, braces (vcat (map toDoc cases))
]
toDoc (Doc brief fields see)
= text "Doc" <+>
text "::" <+>
text "brief=" <+> text (fromMaybe "" brief) <+>
text "fields=" <+>
hsep (punctuate (char ',') $ joinWith ":" $ Map.toList fields) <+>
text ";" <+>
text "see=" <+>
hsep (punctuate (char ',') $ joinWith "." see)
where
joinWith c = map $ \(x,y) -> text $ x ++ c ++ y
toDoc (Fd fd)
= text "Fd" <+>
text "::" <+>
text fd
toDoc (ValueParam typ mname mpad lname)
= text "Valueparam" <+>
text "::" <+>
hsep (punctuate (char ',') details)
where details
| isJust mpad =
[toDoc typ
,text "mask padding:" <+> toDoc mpad
,text mname
,text lname
]
| otherwise =
[toDoc typ
,text mname
,text lname
]
instance Pretty a => Pretty (GenBitCase a) where
toDoc (BitCase name expr fields)
= vcat
[ bitCaseHeader name expr
, braces (vcat (map toDoc fields))
]
bitCaseHeader :: Pretty a => Maybe Name -> Expression a -> Doc
bitCaseHeader Nothing expr =
text "bitcase" <> parens (toDoc expr)
bitCaseHeader (Just name) expr =
text "bitcase" <> parens (toDoc expr) <> brackets (text name)
instance Pretty a => Pretty (GenXDecl a) where
toDoc (XStruct nm elems) =
hang (text "Struct:" <+> text nm) 2 $ vcat $ map toDoc elems
toDoc (XTypeDef nm typ) = hsep [text "TypeDef:"
,text nm
,text "as"
,toDoc typ
]
toDoc (XEvent nm n elems (Just True)) =
hang (text "Event:" <+> text nm <> char ',' <> toDoc n <+>
parens (text "No sequence number")) 2 $
vcat $ map toDoc elems
toDoc (XEvent nm n elems _) =
hang (text "Event:" <+> text nm <> char ',' <> toDoc n) 2 $
vcat $ map toDoc elems
toDoc (XRequest nm n elems mrep) =
(hang (text "Request:" <+> text nm <> char ',' <> toDoc n) 2 $
vcat $ map toDoc elems)
$$ case mrep of
Nothing -> empty
Just reply ->
hang (text "Reply:" <+> text nm <> char ',' <> toDoc n) 2 $
vcat $ map toDoc reply
toDoc (XidType nm) = text "XID:" <+> text nm
toDoc (XidUnion nm elems) =
hang (text "XID" <+> text "Union:" <+> text nm) 2 $
vcat $ map toDoc elems
toDoc (XEnum nm elems) =
hang (text "Enum:" <+> text nm) 2 $ vcat $ map toDoc elems
toDoc (XUnion nm elems) =
hang (text "Union:" <+> text nm) 2 $ vcat $ map toDoc elems
toDoc (XImport nm) = text "Import:" <+> text nm
toDoc (XError nm _n elems) =
hang (text "Error:" <+> text nm) 2 $ vcat $ map toDoc elems
instance Pretty a => Pretty (GenXHeader a) where
toDoc xhd = text (xheader_header xhd) $$
(vcat $ map toDoc (xheader_decls xhd))
|
