{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Data.XCB.Pretty where
import Prelude hiding ((<>))
import Data.XCB.Types
import Text.PrettyPrint.HughesPJ
import qualified Data.Map as Map
import Data.Maybe
class Pretty a where
toDoc :: a -> Doc
pretty :: a -> String
pretty = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Doc
toDoc
toDoc = String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> String
pretty
instance Pretty String where
pretty :: String -> String
pretty = forall a. Show a => a -> String
show
instance Pretty Int where
pretty :: Int -> String
pretty = forall a. Show a => a -> String
show
instance Pretty Bool where
pretty :: Bool -> String
pretty = forall a. Show a => a -> String
show
instance Pretty a => Pretty (Maybe a) where
toDoc :: Maybe a -> Doc
toDoc Maybe a
Nothing = Doc
empty
toDoc (Just a
a) = forall a. Pretty a => a -> Doc
toDoc a
a
pretty :: Maybe a -> String
pretty Maybe a
Nothing = String
""
pretty (Just a
a) = forall a. Pretty a => a -> String
pretty a
a
instance Pretty a => Pretty (GenXidUnionElem a) where
toDoc :: GenXidUnionElem a -> Doc
toDoc (XidUnionElem a
t) = forall a. Pretty a => a -> Doc
toDoc a
t
instance Pretty Binop where
pretty :: Binop -> String
pretty Binop
Add = String
"+"
pretty Binop
Sub = String
"-"
pretty Binop
Mult = String
"*"
pretty Binop
Div = String
"/"
pretty Binop
RShift = String
">>"
pretty Binop
And = String
"&"
instance Pretty Unop where
pretty :: Unop -> String
pretty Unop
Complement = String
"~"
instance Pretty a => Pretty (EnumElem a) where
toDoc :: EnumElem a -> Doc
toDoc (EnumElem String
name Maybe (Expression a)
expr)
= String -> Doc
text String
name Doc -> Doc -> Doc
<> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe (Expression a)
expr
instance Pretty Type where
toDoc :: Type -> Doc
toDoc (UnQualType String
name) = String -> Doc
text String
name
toDoc (QualType String
modifier String
name)
= String -> Doc
text String
modifier Doc -> Doc -> Doc
<> Char -> Doc
char Char
'.' Doc -> Doc -> Doc
<> String -> Doc
text String
name
instance Pretty a => Pretty (Expression a) where
toDoc :: Expression a -> Doc
toDoc (Value Int
n) = forall a. Pretty a => a -> Doc
toDoc Int
n
toDoc (Bit Int
n) = String -> Doc
text String
"2^" Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
toDoc Int
n
toDoc (FieldRef String
ref) = Char -> Doc
char Char
'$' Doc -> Doc -> Doc
<> String -> Doc
text String
ref
toDoc (EnumRef a
typ String
child)
= forall a. Pretty a => a -> Doc
toDoc a
typ Doc -> Doc -> Doc
<> Char -> Doc
char Char
'.' Doc -> Doc -> Doc
<> String -> Doc
text String
child
toDoc (PopCount Expression a
expr)
= String -> Doc
text String
"popcount" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall a. Pretty a => a -> Doc
toDoc Expression a
expr)
toDoc (SumOf String
ref)
= String -> Doc
text String
"sumof" Doc -> Doc -> Doc
<> (Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ Char -> Doc
char Char
'$' Doc -> Doc -> Doc
<> String -> Doc
text String
ref)
toDoc (Op Binop
binop Expression a
exprL Expression a
exprR)
= Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep [forall a. Pretty a => a -> Doc
toDoc Expression a
exprL
,forall a. Pretty a => a -> Doc
toDoc Binop
binop
,forall a. Pretty a => a -> Doc
toDoc Expression a
exprR
]
toDoc (Unop Unop
op Expression a
expr)
= Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
toDoc Unop
op Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
toDoc Expression a
expr
toDoc (ParamRef String
n) = forall a. Pretty a => a -> Doc
toDoc String
n
instance Pretty PadType where
pretty :: PadType -> String
pretty PadType
PadBytes = String
"bytes"
pretty PadType
PadAlignment = String
"align"
instance Pretty a => Pretty (GenStructElem a) where
toDoc :: GenStructElem a -> Doc
toDoc (Pad PadType
typ Int
n) = Doc -> Doc
braces forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
toDoc Int
n Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc PadType
typ
toDoc (List String
nm a
typ Maybe (Expression a)
len Maybe a
enums)
= String -> Doc
text String
nm Doc -> Doc -> Doc
<+> String -> Doc
text String
"::" Doc -> Doc -> Doc
<+> Doc -> Doc
brackets (forall a. Pretty a => a -> Doc
toDoc a
typ Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe a
enums) Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe (Expression a)
len
toDoc (SField String
nm a
typ Maybe a
enums Maybe a
mask) = [Doc] -> Doc
hsep [String -> Doc
text String
nm
,String -> Doc
text String
"::"
,forall a. Pretty a => a -> Doc
toDoc a
typ
,forall a. Pretty a => a -> Doc
toDoc Maybe a
enums
,forall a. Pretty a => a -> Doc
toDoc Maybe a
mask
]
toDoc (ExprField String
nm a
typ Expression a
expr)
= Doc -> Doc
parens (String -> Doc
text String
nm Doc -> Doc -> Doc
<+> String -> Doc
text String
"::" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc a
typ)
Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Expression a
expr
toDoc (Switch String
name Expression a
expr Maybe Alignment
alignment [GenBitCase a]
cases)
= [Doc] -> Doc
vcat
[ String -> Doc
text String
"switch" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall a. Pretty a => a -> Doc
toDoc Expression a
expr) Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
toDoc Maybe Alignment
alignment Doc -> Doc -> Doc
<> Doc -> Doc
brackets (String -> Doc
text String
name)
, Doc -> Doc
braces ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [GenBitCase a]
cases))
]
toDoc (Doc Maybe String
brief Map String String
fields [(String, String)]
see)
= String -> Doc
text String
"Doc" Doc -> Doc -> Doc
<+>
String -> Doc
text String
"::" Doc -> Doc -> Doc
<+>
String -> Doc
text String
"brief=" Doc -> Doc -> Doc
<+> String -> Doc
text (forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
brief) Doc -> Doc -> Doc
<+>
String -> Doc
text String
"fields=" Doc -> Doc -> Doc
<+>
[Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate (Char -> Doc
char Char
',') forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> [Doc]
joinWith String
":" forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map String String
fields) Doc -> Doc -> Doc
<+>
String -> Doc
text String
";" Doc -> Doc -> Doc
<+>
String -> Doc
text String
"see=" Doc -> Doc -> Doc
<+>
[Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate (Char -> Doc
char Char
',') forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> [Doc]
joinWith String
"." [(String, String)]
see)
where
joinWith :: String -> [(String, String)] -> [Doc]
joinWith String
c = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \(String
x,String
y) -> String -> Doc
text forall a b. (a -> b) -> a -> b
$ String
x forall a. [a] -> [a] -> [a]
++ String
c forall a. [a] -> [a] -> [a]
++ String
y
toDoc (Fd String
fd)
= String -> Doc
text String
"Fd" Doc -> Doc -> Doc
<+>
String -> Doc
text String
"::" Doc -> Doc -> Doc
<+>
String -> Doc
text String
fd
toDoc (ValueParam a
typ String
mname Maybe Int
mpad String
lname)
= String -> Doc
text String
"Valueparam" Doc -> Doc -> Doc
<+>
String -> Doc
text String
"::" Doc -> Doc -> Doc
<+>
[Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate (Char -> Doc
char Char
',') [Doc]
details)
where details :: [Doc]
details
| forall a. Maybe a -> Bool
isJust Maybe Int
mpad =
[forall a. Pretty a => a -> Doc
toDoc a
typ
,String -> Doc
text String
"mask padding:" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe Int
mpad
,String -> Doc
text String
mname
,String -> Doc
text String
lname
]
| Bool
otherwise =
[forall a. Pretty a => a -> Doc
toDoc a
typ
,String -> Doc
text String
mname
,String -> Doc
text String
lname
]
toDoc (Length a
_ Expression a
expr)
= String -> Doc
text String
"length" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (forall a. Pretty a => a -> Doc
toDoc Expression a
expr)
instance Pretty a => Pretty (GenBitCase a) where
toDoc :: GenBitCase a -> Doc
toDoc (BitCase Maybe String
name Expression a
expr Maybe Alignment
alignment [GenStructElem a]
fields)
= [Doc] -> Doc
vcat
[ forall a. Pretty a => Maybe String -> Expression a -> Doc
bitCaseHeader Maybe String
name Expression a
expr
, forall a. Pretty a => a -> Doc
toDoc Maybe Alignment
alignment
, Doc -> Doc
braces ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [GenStructElem a]
fields))
]
bitCaseHeader :: Pretty a => Maybe Name -> Expression a -> Doc
Maybe String
Nothing Expression a
expr =
String -> Doc
text String
"bitcase" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall a. Pretty a => a -> Doc
toDoc Expression a
expr)
bitCaseHeader (Just String
name) Expression a
expr =
String -> Doc
text String
"bitcase" Doc -> Doc -> Doc
<> Doc -> Doc
parens (forall a. Pretty a => a -> Doc
toDoc Expression a
expr) Doc -> Doc -> Doc
<> Doc -> Doc
brackets (String -> Doc
text String
name)
instance Pretty Alignment where
toDoc :: Alignment -> Doc
toDoc (Alignment Int
align Int
offset) = String -> Doc
text String
"alignment" Doc -> Doc -> Doc
<+>
String -> Doc
text String
"align=" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Int
align Doc -> Doc -> Doc
<+>
String -> Doc
text String
"offset=" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Int
offset
instance Pretty AllowedEvent where
toDoc :: AllowedEvent -> Doc
toDoc (AllowedEvent String
extension Bool
xge Int
opMin Int
opMax) = String -> Doc
text String
"allowed" Doc -> Doc -> Doc
<+>
String -> Doc
text String
"extension=" Doc -> Doc -> Doc
<+> String -> Doc
text String
extension Doc -> Doc -> Doc
<+>
String -> Doc
text String
"xge=" Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
toDoc Bool
xge Doc -> Doc -> Doc
<>
String -> Doc
text String
"opcode-min" Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
toDoc Int
opMin Doc -> Doc -> Doc
<>
String -> Doc
text String
"opcode-max" Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
toDoc Int
opMax
instance Pretty a => Pretty (GenXDecl a) where
toDoc :: GenXDecl a -> Doc
toDoc (XStruct String
nm Maybe Alignment
alignment [GenStructElem a]
elems) =
Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Struct:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe Alignment
alignment) Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [GenStructElem a]
elems
toDoc (XTypeDef String
nm a
typ) = [Doc] -> Doc
hsep [String -> Doc
text String
"TypeDef:"
,String -> Doc
text String
nm
,String -> Doc
text String
"as"
,forall a. Pretty a => a -> Doc
toDoc a
typ
]
toDoc (XEvent String
nm Int
n Maybe Alignment
alignment Maybe Bool
_ [GenStructElem a]
elems (Just Bool
True)) =
Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Event:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm Doc -> Doc -> Doc
<> Char -> Doc
char Char
',' Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
toDoc Int
n Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe Alignment
alignment Doc -> Doc -> Doc
<+>
Doc -> Doc
parens (String -> Doc
text String
"No sequence number")) Int
2 forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [GenStructElem a]
elems
toDoc (XEvent String
nm Int
n Maybe Alignment
alignment Maybe Bool
_ [GenStructElem a]
elems Maybe Bool
_) =
Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Event:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm Doc -> Doc -> Doc
<> Char -> Doc
char Char
',' Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
toDoc Int
n Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe Alignment
alignment) Int
2 forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [GenStructElem a]
elems
toDoc (XRequest String
nm Int
n Maybe Alignment
alignment [GenStructElem a]
elems Maybe (GenXReply a)
mrep) =
(Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Request:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm Doc -> Doc -> Doc
<> Char -> Doc
char Char
',' Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
toDoc Int
n Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe Alignment
alignment) Int
2 forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [GenStructElem a]
elems)
Doc -> Doc -> Doc
$$ case Maybe (GenXReply a)
mrep of
Maybe (GenXReply a)
Nothing -> Doc
empty
Just (GenXReply Maybe Alignment
repAlignment [GenStructElem a]
reply) ->
Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Reply:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm Doc -> Doc -> Doc
<> Char -> Doc
char Char
',' Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
toDoc Int
n Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe Alignment
repAlignment) Int
2 forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [GenStructElem a]
reply
toDoc (XidType String
nm) = String -> Doc
text String
"XID:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm
toDoc (XidUnion String
nm [GenXidUnionElem a]
elems) =
Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"XID" Doc -> Doc -> Doc
<+> String -> Doc
text String
"Union:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm) Int
2 forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [GenXidUnionElem a]
elems
toDoc (XEnum String
nm [EnumElem a]
elems) =
Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Enum:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm) Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [EnumElem a]
elems
toDoc (XUnion String
nm Maybe Alignment
alignment [GenStructElem a]
elems) =
Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Union:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe Alignment
alignment) Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [GenStructElem a]
elems
toDoc (XImport String
nm) = String -> Doc
text String
"Import:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm
toDoc (XError String
nm Int
_n Maybe Alignment
alignment [GenStructElem a]
elems) =
Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Error:" Doc -> Doc -> Doc
<+> String -> Doc
text String
nm Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
toDoc Maybe Alignment
alignment) Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [GenStructElem a]
elems
toDoc (XEventStruct String
name [AllowedEvent]
allowed) =
Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Event struct:" Doc -> Doc -> Doc
<+> String -> Doc
text String
name) Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc [AllowedEvent]
allowed
instance Pretty a => Pretty (GenXHeader a) where
toDoc :: GenXHeader a -> Doc
toDoc GenXHeader a
xhd = String -> Doc
text (forall typ. GenXHeader typ -> String
xheader_header GenXHeader a
xhd) Doc -> Doc -> Doc
$$
([Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
toDoc (forall typ. GenXHeader typ -> [GenXDecl typ]
xheader_decls GenXHeader a
xhd))