{-# 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 Prelude hiding ((<>))

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 = 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

-- Builtin types

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

-- Simple stuff

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

-- More complex stuff

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 a => Pretty (GenStructElem a) where
    toDoc :: GenStructElem a -> Doc
toDoc (Pad Int
n) = Doc -> Doc
braces forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
toDoc Int
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"bytes"
    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
bitCaseHeader :: forall a. Pretty a => Maybe String -> Expression a -> Doc
bitCaseHeader 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))