content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  -- |
  -- Module      :  Language.C.Pretty
  -- Copyright   :  (c) 2006-2011 Harvard University
  --                (c) 2011-2013 Geoffrey Mainland
  --             :  (c) 2013-2016 Drexel University
  -- License     :  BSD-style
  -- Maintainer  :  mainland@drexel.edu
  
  module Language.C.Pretty where
  
  import Data.Char (isAlphaNum,
                    isLower)
  import Data.Loc
  import Data.Maybe (isJust)
  #if !(MIN_VERSION_base(4,9,0))
  import Data.Monoid (Monoid(..), (<>))
  #endif /* !(MIN_VERSION_base(4,9,0)) */
  #if MIN_VERSION_base(4,9,0) && !(MIN_VERSION_base(4,11,0))
  import Data.Semigroup (Semigroup(..))
  #endif
  
  import Language.C.Syntax
  import Text.PrettyPrint.Mainland
  import Text.PrettyPrint.Mainland.Class
  
  pprLoc :: SrcLoc -> Doc -> Doc
  pprLoc loc doc = srcloc loc <> doc
  
  data Fixity = Fixity Assoc Int
    deriving (Eq, Ord)
  
  data Assoc = LeftAssoc | RightAssoc | NonAssoc
    deriving (Eq, Ord)
  
  infix_ :: Int -> Fixity
  infix_ = Fixity NonAssoc
  
  infixl_ :: Int -> Fixity
  infixl_ = Fixity LeftAssoc
  
  infixr_ :: Int -> Fixity
  infixr_ = Fixity RightAssoc
  
  -- | Pretty print infix binary operators
  infixop :: (Pretty a, Pretty b, Pretty op, CFixity op)
          => Int -- ^ precedence of context
          -> op  -- ^ operator
          -> a   -- ^ left argument
          -> b   -- ^ right argument
          -> Doc
  infixop prec op l r =
      parensOp prec op $
      pprPrec leftPrec l <+> ppr op <+/> pprPrec rightPrec r
    where
      leftPrec | opAssoc == RightAssoc = opPrec + 1
               | otherwise             = opPrec
  
      rightPrec | opAssoc == LeftAssoc = opPrec + 1
                | otherwise            = opPrec
  
      Fixity opAssoc opPrec = fixity op
  
  -- | Pretty print prefix unary operators
  prefixop :: (Pretty a, Pretty op, CFixity op)
           => Int -- ^ precedence of context
           -> op  -- ^ operator
           -> a   -- ^ argument
           -> Doc
  prefixop prec op arg =
      parensIf (prec > opPrec) $
      ppr op <> pprPrec rightPrec arg
    where
      rightPrec | opAssoc == LeftAssoc = opPrec + 1
                | otherwise            = opPrec
  
      Fixity opAssoc opPrec = fixity op
  
  parensList :: [Doc] -> Doc
  parensList = enclosesep lparen rparen comma
  
  bracesList :: [Doc] -> Doc
  bracesList = enclosesep lbrace rbrace comma
  
  bracesSemiList :: [Doc] -> Doc
  bracesSemiList = enclosesep lbrace rbrace semi
  
  angleList :: [Doc] -> Doc
  angleList = enclosesep langle rangle comma
  
  embrace :: [Doc] -> Doc
  embrace [] = lbrace <+> rbrace
  embrace ds = lbrace <>
               nest 4 (line <> stack ds) </>
               rbrace
  
  pprAnti :: String -> String -> Doc
  pprAnti anti s = char '$' <> text anti <> colon <>
                   if isIdentifier s then text s else parens (text s)
    where
      isIdentifier :: String -> Bool
      isIdentifier []       = False
      isIdentifier ('_':cs) = all isIdChar cs
      isIdentifier (c:cs)   = isLower c && all isIdChar cs
  
      isIdChar :: Char -> Bool
      isIdChar '_' = True
      isIdChar c   = isAlphaNum c
  
  class CFixity a where
      fixity :: a -> Fixity
  
      parensOp :: Int -> a -> Doc -> Doc
      parensOp prec op =
          parensIf (prec > opPrec)
        where
          Fixity _ opPrec = fixity op
  
  --
  -- Fixities are taken from Table 2-1 in Section 2.12 of K&R (2nd ed.)
  --
  commaPrec :: Int
  commaPrec = 1
  
  commaPrec1 :: Int
  commaPrec1 = commaPrec + 1
  
  condPrec :: Int
  condPrec = 3
  
  condPrec1 :: Int
  condPrec1 = condPrec + 1
  
  unopPrec :: Int
  unopPrec = 14
  
  unopPrec1 :: Int
  unopPrec1 = unopPrec + 1
  
  memberPrec :: Int
  memberPrec = 15
  
  memberPrec1 :: Int
  memberPrec1 = memberPrec + 1
  
  instance CFixity BinOp where
      fixity Add  = infixl_ 12
      fixity Sub  = infixl_ 12
      fixity Mul  = infixl_ 13
      fixity Div  = infixl_ 13
      fixity Mod  = infixl_ 13
      fixity Eq   = infixl_ 9
      fixity Ne   = infixl_ 9
      fixity Lt   = infixl_ 10
      fixity Gt   = infixl_ 10
      fixity Le   = infixl_ 10
      fixity Ge   = infixl_ 10
      fixity Land = infixl_ 5
      fixity Lor  = infixl_ 4
      fixity And  = infixl_ 8
      fixity Or   = infixl_ 6
      fixity Xor  = infixl_ 7
      fixity Lsh  = infixl_ 11
      fixity Rsh  = infixl_ 11
  
      parensOp prec op =
          go op
        where
          go :: BinOp -> Doc -> Doc
          go Add  | isBitwiseOp = parens
          go Sub  | isBitwiseOp = parens
          go Land | isOp Lor    = parens
          go Lor  | isOp Land   = parens
          go And  | isOp Or     = parens
                  | isOp Xor    = parens
          go Or   | isOp And    = parens
                  | isOp Xor    = parens
          go Xor  | isOp And    = parens
                  | isOp Or     = parens
          go _                  = parensIf (prec > opPrec)
  
          isBitwiseOp :: Bool
          isBitwiseOp = isOp And || isOp Or || isOp Xor
  
          -- Return 'True' if we are potentially an immediate subterm of the
          -- binary operator op'. We make this determination based of the value of
          -- @prec@.
          isOp :: BinOp -> Bool
          isOp op' = prec == op'Prec || prec == op'Prec + 1
            where
              Fixity _ op'Prec = fixity op'
  
          Fixity _ opPrec = fixity op
  
  instance CFixity AssignOp where
      fixity _ = infixr_ 2
  
  instance CFixity UnOp where
      fixity _ = infixr_ unopPrec
  
  instance Pretty Id where
      ppr (Id ident _)  = text ident
      ppr (AntiId v _)  = pprAnti "id" v
  
  instance Pretty StringLit where
      ppr (StringLit ss _ _) = sep (map string ss)
  
  instance Pretty Storage where
      ppr (Tauto _)                    = text "auto"
      ppr (Tregister _)                = text "register"
      ppr (Tstatic _)                  = text "static"
      ppr (Textern Nothing _)          = text "extern"
      ppr (Textern (Just l) _)         = text "extern" <+> ppr l
      ppr (Ttypedef _)                 = text "typedef"
      ppr (T__block _)                 = text "__block"
      ppr (TObjC__weak _)              = text "__weak"
      ppr (TObjC__strong _)            = text "__strong"
      ppr (TObjC__unsafe_unretained _) = text "__unsafe_unretained"
  
  instance Pretty TypeQual where
      ppr (Tconst _)          = text "const"
      ppr (Tvolatile _)       = text "volatile"
  
      ppr (EscTypeQual esc _) = text esc
  
      ppr (AntiTypeQual v _)  = pprAnti "tyqual" v
      ppr (AntiTypeQuals v _) = pprAnti "tyquals" v
  
      ppr (Tinline _)         = text "inline"
      ppr (Trestrict _)       = text "restrict"
  
      ppr (TAttr attr)        = ppr [attr]
      ppr (T__restrict _)     = text "__restrict"
  
      ppr (TCUDAdevice _)     = text "__device__"
      ppr (TCUDAglobal _)     = text "__global__"
      ppr (TCUDAhost _)       = text "__host__"
      ppr (TCUDAconstant _)   = text "__constant__"
      ppr (TCUDAshared _)     = text "__shared__"
      ppr (TCUDArestrict _)   = text "__restrict__"
      ppr (TCUDAnoinline _)   = text "__noinline__"
  
      ppr (TCLprivate _)      = text "__private"
      ppr (TCLlocal _)        = text "__local"
      ppr (TCLglobal _)       = text "__global"
      ppr (TCLconstant _)     = text "__constant"
      ppr (TCLreadonly _)     = text "read_only"
      ppr (TCLwriteonly _)    = text "write_only"
      ppr (TCLkernel _)       = text "__kernel"
  
  instance Pretty Sign where
      ppr (Tsigned _)    = text "signed"
      ppr (Tunsigned _)  = text "unsigned"
  
  instance Pretty TypeSpec where
      ppr (Tvoid _)            = text "void"
      ppr (Tchar sign _)       = ppr sign <+> text "char"
      ppr (Tshort sign _)      = ppr sign <+> text "short"
      ppr (Tint sign _)        = ppr sign <+> text "int"
      ppr (Tlong sign _)       = ppr sign <+> text "long"
      ppr (Tlong_long sign _)  = ppr sign <+> text "long long"
      ppr (Tfloat _)           = text "float"
      ppr (Tdouble _)          = text "double"
      ppr (Tlong_double _)     = text "long double"
  
      ppr (Tstruct maybe_ident maybe_fields attrs _) =
          align $ pprStructOrUnion "struct" maybe_ident maybe_fields attrs
  
      ppr (Tunion maybe_ident maybe_fields attrs _) =
          align $ pprStructOrUnion "union" maybe_ident maybe_fields attrs
  
      ppr (Tenum maybe_ident cenums attrs _) =
          align $ pprEnum maybe_ident cenums attrs
  
      ppr (Tnamed ident refs _) =
          ppr ident <> if null refs then empty else angles (commasep (map ppr refs))
  
      ppr (T_Bool _) =
          text "_Bool"
  
      ppr (Tfloat_Complex _) =
          text "float" <+> text "_Complex"
  
      ppr (Tdouble_Complex _) =
          text "double" <+> text "_Complex"
  
      ppr (Tlong_double_Complex _) =
          text "long" <+> text "double" <+> text "_Complex"
  
      ppr (Tfloat_Imaginary _) =
          text "float" <+> text "_Imaginary"
  
      ppr (Tdouble_Imaginary _) =
          text "double" <+> text "_Imaginary"
  
      ppr (Tlong_double_Imaginary _) =
          text "long" <+> text "double" <+> text "_Imaginary"
  
      ppr (TtypeofExp e _) =
          text "__typeof__" <> parens (pprPrec 14 e)
  
      ppr (TtypeofType tipe _) =
          text "__typeof__" <> parens (ppr tipe)
  
      ppr (Tva_list _) =
          text "__builtin_va_list"
  
  pprStructOrUnion :: String
                   -> Maybe Id
                   -> Maybe [FieldGroup]
                   -> [Attr]
                   -> Doc
  pprStructOrUnion ty maybe_ident maybe_fields attrs =
      text ty <+> ppr maybe_ident <+> ppr maybe_fields <+/> ppr attrs
  
  pprEnum :: Maybe Id
          -> [CEnum]
          -> [Attr]
          -> Doc
  pprEnum maybe_ident cenums attrs =
      text "enum" <+> ppr maybe_ident <+> ppr cenums <+/> ppr attrs
  
  instance Pretty DeclSpec where
      ppr (DeclSpec storage quals spec _) =
          case map ppr storage ++ map ppr quals of
            []   -> ppr spec
            docs -> spread docs <+/> ppr spec
  
      ppr (AntiDeclSpec v _) =
          pprAnti "spec" v
  
      ppr (AntiTypeDeclSpec storage quals v _) =
          spread (map ppr storage ++ map ppr quals) <+/>
          pprAnti "ty" v
  
  instance Pretty ArraySize where
      ppr (ArraySize True e _)  = text "static" <+> ppr e
      ppr (ArraySize False e _) = ppr e
      ppr (VariableArraySize _) = text "*"
      ppr (NoArraySize _)       = empty
  
  pprDeclarator :: Maybe Id -> Decl -> Doc
  pprDeclarator maybe_ident declarator =
      case maybe_ident of
        Nothing ->    pprDecl declarator empty
        Just ident -> pprDecl declarator (ppr ident)
      where
        pprPtr :: Decl -> Doc -> (Decl, Doc)
        pprPtr (Ptr quals decl _) post =
            pprPtr decl $
            text "*" <> spread (map ppr quals) <+> post
  
        pprPtr (BlockPtr quals decl _) post =
            pprPtr decl $
            text "^" <> spread (map ppr quals) <+> post
  
        pprPtr decl post =
            (decl, post)
  
        pprDirDecl :: Decl -> Doc -> (Decl, Doc)
        pprDirDecl (Array quals size decl _) pre =
            pprDirDecl decl $
            pre <> brackets (align (spread (map ppr quals) <+> ppr size))
  
        pprDirDecl (Proto decl args _) pre =
            pprDirDecl decl $
            pre <> parens (ppr args)
  
        pprDirDecl (OldProto decl args _) pre =
            pprDirDecl decl $
            pre <> parensList (map ppr args)
  
        pprDirDecl decl pre =
            (decl, pre)
  
        pprDecl :: Decl -> Doc -> Doc
        pprDecl decl mid =
            case decl' of
              DeclRoot {}     -> declDoc
              AntiTypeDecl {} -> declDoc
              _               -> pprDecl decl' (parens declDoc)
          where
            (decl', declDoc) = uncurry pprPtr (pprDirDecl decl mid)
  
  instance Pretty Type where
      ppr (Type spec decl _)  = ppr spec <+> pprDeclarator Nothing decl
      ppr (AntiType v _)      = pprAnti "ty" v
  
  instance Pretty Designator where
      ppr (IndexDesignator e _)       = brackets $ ppr e
      ppr (MemberDesignator ident _)  = dot <> ppr ident
  
  instance Pretty Designation where
      ppr (Designation ds _) = folddoc (<>) (map ppr ds)
  
  instance Pretty Initializer where
      ppr (ExpInitializer e _) = ppr e
  
      ppr (CompoundInitializer inits _) =
          bracesList (map pprInit inits)
        where
          pprInit :: (Maybe Designation, Initializer) -> Doc
          pprInit (Nothing, ini) = ppr ini
          pprInit (Just d, ini)  = ppr d <+> text "=" <//> ppr ini
  
      ppr (AntiInit v _)  = pprAnti "init" v
      ppr (AntiInits v _) = pprAnti "inits" v
  
  instance Pretty Init where
      ppr (Init ident decl maybe_asmlabel maybe_e attrs _) =
          pprDeclarator (Just ident) decl <+/> ppr attrs
          <+> case maybe_asmlabel of
                Nothing -> empty
                Just l ->  text "asm" <+> parens (ppr l)
          <+> case maybe_e of
                Nothing -> empty
                Just e ->  text "=" <+/> ppr e
  
  instance Pretty Typedef where
      ppr (Typedef ident decl attrs loc) =
          ppr (Init ident decl Nothing Nothing attrs loc)
  
  instance Pretty InitGroup where
      ppr (InitGroup spec attrs inits _) =
          ppr spec <+/> ppr attrs <+> commasep (map ppr inits)
  
      ppr (TypedefGroup spec attrs typedefs _) =
          text "typedef" <+> ppr spec <+/> ppr attrs <+> commasep (map ppr typedefs)
  
      ppr (AntiDecls v _)  = pprAnti "decls" v
      ppr (AntiDecl v _)   = pprAnti "decl" v
  
      pprList initgroups =
          stack (zipWith (<>) (map ppr initgroups) (repeat semi))
  
  instance Pretty Field where
      ppr (Field maybe_ident maybe_decl maybe_e _) =
          case maybe_decl of
            Nothing   -> empty
            Just decl -> pprDeclarator maybe_ident decl
          <+>
          case maybe_e of
            Nothing -> empty
            Just e  -> colon <+> ppr e
  
  instance Pretty FieldGroup where
      ppr (FieldGroup spec fields _) =
          ppr spec <+> commasep (map ppr fields)
  
      ppr (AntiSdecls v _)  = pprAnti "sdecls" v
      ppr (AntiSdecl v _)   = pprAnti "sdecl" v
  
      pprList fields = embrace (zipWith (<>) (map ppr fields) (repeat semi))
  
  instance Pretty CEnum where
      ppr (CEnum ident maybe_e _) =
          ppr ident <+>
          case maybe_e of
            Nothing -> empty
            Just e ->  text "=" <+/> ppr e
  
      ppr (AntiEnums v _)  = pprAnti "enums" v
      ppr (AntiEnum v _)   = pprAnti "enum" v
  
      pprList []     = empty
      pprList cenums = embrace (zipWith (<>) (map ppr cenums) (repeat comma))
  
  instance Pretty Attr where
      ppr (Attr ident [] _) = ppr ident
      ppr (Attr ident args _) =
          ppr ident <> parens (commasep (map ppr args))
  
      ppr (AntiAttr v _)   = pprAnti "attr" v
      ppr (AntiAttrs v _)  = pprAnti "attrs" v
  
      pprList []    = empty
      pprList attrs = text "__attribute__" <>
                      parens (parens (commasep (map ppr attrs)))
  
  instance Pretty Param where
      ppr (Param maybe_ident spec decl _) =
          ppr spec <+> pprDeclarator maybe_ident decl
  
      ppr (AntiParams v _)  = pprAnti "params" v
      ppr (AntiParam v _)   = pprAnti "param" v
  
  instance Pretty Params where
      ppr (Params args True _) =
          commasep (map ppr args ++ [text "..."])
  
      ppr (Params args False _) =
          commasep (map ppr args)
  
  instance Pretty Func where
      ppr (Func spec ident decl args body loc) =
          ppr spec <+> pprDeclarator (Just ident) (Proto decl args loc) </> ppr body
  
      ppr (OldFunc spec ident decl args maybe_initgroups body loc) =
          ppr spec <+> pprDeclarator (Just ident) (OldProto decl args loc) </>
          ppr maybe_initgroups </>
          ppr body
  
  instance Pretty Definition where
      ppr (FuncDef func loc)      = srcloc loc <> ppr func
      ppr (DecDef initgroup loc)  = srcloc loc <> ppr initgroup <> semi
      ppr (EscDef s loc)          = srcloc loc <> text s
      ppr (ObjCClassDec clss loc) = srcloc loc <> text "@class" <+> commasep (map ppr clss) <> semi
  
      ppr (AntiFunc v _)    = pprAnti "func" v
      ppr (AntiEsc v _)     = pprAnti "esc" v
      ppr (AntiEdecls v _)  = pprAnti "edecls" v
      ppr (AntiEdecl v _)   = pprAnti "edecl" v
  
      ppr (ObjCClassIface cident sident refs ivars decls attrs loc) =
          srcloc loc <+> ppr attrs <+/>
          text "@interface" <+> ppr cident <+> maybe empty (\ident -> char ':' <+> ppr ident) sident <+>
          pprIfaceBody refs ivars decls
  
      ppr (ObjCCatIface cident catident refs ivars decls loc) =
          srcloc loc <>
          text "@interface" <+> ppr cident <+> parens (maybe empty ppr catident) <+> pprIfaceBody refs ivars decls
  
      ppr (ObjCProtDec prots loc) =
          srcloc loc <> text "@protocol" <+> commasep (map ppr prots) <> semi
  
      ppr (ObjCProtDef pident refs decls loc) =
          srcloc loc <>
          text "@protocol" <+> ppr pident <+> pprIfaceBody refs [] decls
  
      ppr (ObjCClassImpl cident sident ivars defs loc) =
          srcloc loc <>
          text "@implementation" <+> ppr cident <+> maybe empty (\ident -> char ':' <+> ppr ident) sident </>
          stack (map ppr ivars) <//>
          stack (map ppr defs) </>
          text "@end"
  
      ppr (ObjCCatImpl cident catident defs loc) =
          srcloc loc <>
          text "@implementation" <+> ppr cident <+> parens (ppr catident) <//>
          stack (map ppr defs) </>
          text "@end"
  
      ppr (ObjCSynDef pivars loc) =
          srcloc loc <>
          text "@synthesize" <+> commasep (map pprPivar pivars) <> semi
        where
          pprPivar (ident,  Nothing)     = ppr ident
          pprPivar (ident1, Just ident2) = ppr ident1 <> char '=' <> ppr ident2
  
      ppr (ObjCDynDef pivars loc) =
          srcloc loc <>
          text "@dynamic" <+> commasep (map ppr pivars) <> semi
  
      ppr (ObjCMethDef proto body loc) =
          srcloc loc <>
          ppr proto </> ppr body
  
      ppr (ObjCCompAlias aident cident loc) =
          srcloc loc <>
          text "@compatibility_alias" <+> ppr aident <+> ppr cident
  
      ppr (AntiObjCMeth v _)  = pprAnti "methdef" v
      ppr (AntiObjCMeths v _) = pprAnti "methdefs" v
  
      pprList ds = stack (map ppr ds) <> line
  
  pprIfaceBody :: [Id] -> [ObjCIvarDecl] -> [ObjCIfaceDecl] -> Doc
  pprIfaceBody refs ivars decls =
      case refs of
        [] -> empty
        _  -> angleList (map ppr refs)
      </>  stack (map ppr ivars)
      <//> stack (map ppr decls)
      </>  text "@end"
  
  instance Pretty Stm where
      ppr (Label ident attrs stm sloc) =
          srcloc sloc <>
          indent (-2) (line <> ppr ident <> colon <+> ppr attrs) </> ppr stm
  
      ppr (Case e stm sloc) =
          srcloc sloc <>
          indent (-2) (line <> text "case" <+> ppr e <> colon) </> ppr stm
  
      ppr (CaseRange e1 e2 stm sloc) =
          srcloc sloc <>
          indent (-2) (line <> text "case" <+> ppr e1 <+> text "..." <+> ppr e2 <> colon) </> ppr stm
  
      ppr (Default stm sloc) =
          srcloc sloc <>
          indent (-2) (line <> text "default" <> colon) </> ppr stm
  
      ppr (Exp Nothing sloc) =
          srcloc sloc <> semi
  
      ppr (Exp (Just e) sloc) =
          srcloc sloc <> hang 4 (ppr e) <> semi
  
      ppr (Block items sloc) =
          srcloc sloc <> ppr items
  
      ppr (If test then' maybe_else sloc) =
          srcloc sloc <>
          text "if" <+> parens (ppr test) <>
          pprThen then' (fmap pprElse maybe_else)
        where
          isIf :: Stm -> Bool
          isIf If{} = True
          isIf (Comment _ stm _) = isIf stm
          isIf _ = False
  
          pprThen :: Stm -> Maybe Doc -> Doc
          pprThen stm@(Block {}) rest        = space <> ppr stm <+> maybe empty id rest
          pprThen stm            rest
            | isIf stm                       = space <> ppr [BlockStm stm] <+> maybe empty id rest
          pprThen stm            Nothing     = nest 4 (line <> ppr stm)
          pprThen stm            (Just rest) = nest 4 (line <> ppr stm) </> rest
  
          pprElse :: Stm -> Doc
          pprElse stm =
              text "else" <> go stm
            where
              go :: Stm -> Doc
              go (Block {}) = space <> ppr stm
              go (If {})    = space <> ppr stm
              go _stm       = nest 4 (line <> ppr stm)
  
      ppr (Switch e stm sloc) =
          srcloc sloc <>
          text "switch" <+> parens (ppr e) <> pprBlock stm
  
      ppr (While e stm sloc) =
          srcloc sloc <>
          text "while" <+> parens (ppr e) <> pprBlock stm
  
      ppr (DoWhile stm e sloc) =
          srcloc sloc <>
          text "do" <> pprBlock stm <+/> text "while" <> parens (ppr e) <> semi
  
      ppr (For ini test post stm sloc) =
          srcloc sloc <>
          text "for" <+>
          (parens . semisep) [either ppr ppr ini, ppr test, ppr post] <>
          pprBlock stm
  
      ppr (Goto ident sloc) =
          srcloc sloc <>
          text "goto" <+> ppr ident <> semi
  
      ppr (Continue sloc) =
          srcloc sloc <> text "continue" <>semi
  
      ppr (Break sloc) =
          srcloc sloc <> text "break" <> semi
  
      ppr (Return Nothing sloc) =
          srcloc sloc <> text "return" <> semi
  
      ppr (Return (Just e) sloc) =
          srcloc sloc <> nest 4 (text "return" <+> ppr e) <> semi
  
      ppr (Pragma pragma sloc) =
          srcloc sloc <> text "#pragma" <+> text pragma
  
      ppr (Comment com stm sloc) =
          align $ srcloc sloc <> text com </> ppr stm
  
      ppr (EscStm esc sloc) =
          srcloc sloc <> text esc
  
      ppr (AntiEscStm v _)      = pprAnti "escstm" v
      ppr (AntiPragma v _)      = pprAnti "pragma" v
      ppr (AntiComment v stm _) = pprAnti "pragma" v </> ppr stm
      ppr (AntiStm v _)         = pprAnti "stm" v
      ppr (AntiStms v _)        = pprAnti "stms" v
  
      ppr (Asm isVolatile _ template outs ins clobbered sloc) =
          srcloc sloc <>
          text "__asm__"
          <> case isVolatile of
               True ->  space <> text "__volatile__"
               False -> empty
          <> parens (ppr template
                     <> case outs of
                          [] -> space <> colon
                          _ ->  colon <+/> ppr outs
                     <> case ins of
                          [] -> space <> colon
                          _ ->  colon <+/> ppr ins
                     <> case clobbered of
                          [] -> space <> colon
                          _ ->  colon <+/> commasep (map text clobbered)
                    )
          <> semi
  
      ppr (AsmGoto isVolatile _ template ins clobbered labels sloc) =
          srcloc sloc <>
          text "__asm__"
          <> case isVolatile of
               True ->  space <> text "__volatile__"
               False -> empty
          <> parens (ppr template
                     <> colon
                     <> case ins of
                          [] -> space <> colon
                          _ ->  colon <+/> ppr ins
                     <> case clobbered of
                          [] -> space <> colon
                          _ ->  colon <+/> commasep (map text clobbered)
                     <> case clobbered of
                          [] -> space <> colon
                          _ ->  colon <+/> commasep (map ppr labels)
                    )
          <> semi
  
      ppr (ObjCTry try catchs finally sloc) =
          srcloc sloc
          <>  text "@try"
          </> ppr try
          </> stack (map ppr catchs)
          </> case finally of
                Nothing    -> empty
                Just block -> text "@finally" </> ppr block
  
      ppr (ObjCThrow e sloc) =
          srcloc sloc
          <> text "@throw"
          <> case e of
               Nothing -> semi
               Just e' -> space <> ppr e' <> semi
  
      ppr (ObjCSynchronized e block sloc) =
          srcloc sloc
          <>  text "@synchronized" <+> parens (ppr e)
          </> ppr block
  
      ppr (ObjCAutoreleasepool block sloc) =
          srcloc sloc
          <>  text "@autoreleasepool"
          </> ppr block
  
  pprBlock :: Stm -> Doc
  pprBlock stm@(Block {}) = space <> ppr stm
  pprBlock stm@(If {})    = space <> ppr [BlockStm stm]
  pprBlock stm            = nest 4 $ line <> ppr stm
  
  instance Pretty BlockItem where
      ppr (BlockDecl decl) = ppr decl <> semi
      ppr (BlockStm stm)   = ppr stm
  
      ppr (AntiBlockItem v _)  = pprAnti "item" v
      ppr (AntiBlockItems v _) = pprAnti "items" v
  
      pprList = embrace . loop
        where
          loop :: [BlockItem] -> [Doc]
          loop [] =
              []
          loop [item] =
              [ppr item]
          loop (item1@(BlockDecl _) : item2@(BlockStm _) : items) =
              (ppr item1 <> line) : loop (item2 : items)
          loop (item1@(BlockStm _) : item2@(BlockDecl _) : items) =
              (ppr item1 <> line) : loop (item2 : items)
          loop (item : items) =
              ppr item : loop items
  
  instance Pretty Const where
      pprPrec p (IntConst s _ i _)          = parensIf (i < 0 && p > unopPrec) $
                                              text s
      pprPrec p (LongIntConst s _ i _)      = parensIf (i < 0 && p > unopPrec) $
                                              text s
      pprPrec p (LongLongIntConst s _ i _)  = parensIf (i < 0 && p > unopPrec) $
                                              text s
      pprPrec p (FloatConst s r _)          = parensIf (r < 0 && p > unopPrec) $
                                              text s
      pprPrec p (DoubleConst s r _)         = parensIf (r < 0 && p > unopPrec) $
                                              text s
      pprPrec p (LongDoubleConst s r _)     = parensIf (r < 0 && p > unopPrec) $
                                              text s
      pprPrec _ (CharConst s _ _)           = text s
      pprPrec _ (StringConst ss _ _)        = sep (map string ss)
  
      pprPrec _ (AntiConst v _)       = pprAnti "const"  v
      pprPrec _ (AntiString v _)      = pprAnti "string"  v
      pprPrec _ (AntiChar v _)        = pprAnti "char"    v
      pprPrec _ (AntiLongDouble v _)  = pprAnti "ldouble" v
      pprPrec _ (AntiDouble v _)      = pprAnti "double"  v
      pprPrec _ (AntiFloat v _)       = pprAnti "float"   v
      pprPrec _ (AntiULInt v _)       = pprAnti "ulint"   v
      pprPrec _ (AntiLInt v _)        = pprAnti "lint"    v
      pprPrec _ (AntiULLInt v _)      = pprAnti "ullint"  v
      pprPrec _ (AntiLLInt v _)       = pprAnti "llint"   v
      pprPrec _ (AntiUInt v _)        = pprAnti "uint"    v
      pprPrec _ (AntiInt v _)         = pprAnti "int"     v
  
  instance Pretty Exp where
      pprPrec p (Var ident loc) =
          pprLoc loc $
          pprPrec p ident
  
      pprPrec p (Const k loc) =
          pprLoc loc $
          pprPrec p k
  
      pprPrec p (BinOp op e1 e2 loc) =
          pprLoc loc $
          infixop p op e1 e2
  
      pprPrec p (Assign e1 op e2 loc) =
          pprLoc loc $
          infixop p op e1 e2
  
      pprPrec p (PreInc e loc) =
          pprLoc loc $
          parensIf (p > unopPrec) $
          text "++" <> pprPrec unopPrec1 e
  
      pprPrec p (PostInc e loc) =
          pprLoc loc $
          parensIf (p > unopPrec) $
          pprPrec unopPrec1 e <> text "++"
  
      pprPrec p (PreDec e loc) =
          pprLoc loc $
          parensIf (p > unopPrec) $
          text "--" <> pprPrec unopPrec1 e
  
      pprPrec p (PostDec e loc) =
          pprLoc loc $
          parensIf (p > unopPrec) $
          pprPrec unopPrec1 e <> text "--"
  
      pprPrec _ (EscExp e loc) =
          srcloc loc <> text e
  
      pprPrec p (AntiEscExp e loc) =
          pprLoc loc $
          parensIf (p > unopPrec) $
          text e
  
      -- When printing leading + and - operators, we print the argument at
      -- precedence 'unopPrec1' to ensure we get parentheses in cases like
      -- @-(-42)@. The same holds for @++@ and @--@ above.
      pprPrec p (UnOp op@Positive e loc) =
          pprLoc loc $
          parensIf (p > unopPrec) $
          ppr op <> pprPrec unopPrec1 e
  
      pprPrec p (UnOp op@Negate e loc) =
          pprLoc loc $
          parensIf (p > unopPrec) $
          ppr op <> pprPrec unopPrec1 e
  
      pprPrec p (UnOp op e loc) =
          pprLoc loc $
          prefixop p op e
  
      pprPrec p (SizeofExp e loc) =
          pprLoc loc $
          parensIf (p > unopPrec) $
          text "sizeof" <> parens (ppr e)
  
      pprPrec p (SizeofType tipe loc) =
          pprLoc loc $
          parensIf (p > unopPrec) $
          text "sizeof" <> parens (ppr tipe)
  
      pprPrec p (Cast tipe e loc) =
          pprLoc loc $
          parensIf (p > unopPrec) $
          parens (ppr tipe) <+> pprPrec unopPrec e
  
      pprPrec p (Cond test then' else' loc) =
          pprLoc loc $
          parensIf (p > condPrec) $
          pprPrec condPrec1 test <+> text "?" <+>
          pprPrec condPrec1 then' <+> colon <+>
          pprPrec condPrec else'
  
      pprPrec p (Member e ident loc) =
          pprLoc loc $
          parensIf (p > memberPrec) $
          pprPrec memberPrec e <> dot <> ppr ident
  
      pprPrec p (PtrMember e ident loc) =
          pprLoc loc $
          parensIf (p > memberPrec) $
          pprPrec memberPrec e <> text "->" <> ppr ident
  
      pprPrec p (Index e1 e2 loc) =
          pprLoc loc $
          parensIf (p > memberPrec) $
          pprPrec memberPrec e1 <> brackets (ppr e2)
  
      pprPrec p (FnCall f args loc) =
          pprLoc loc $
          parensIf (p > memberPrec) $
          pprPrec memberPrec f <> parensList (map ppr args)
  
      pprPrec p (Seq e1 e2 loc) =
          pprLoc loc $
          parensIf (p > commaPrec) $
          pprPrec commaPrec e1 <> comma <+/> pprPrec commaPrec1 e2
  
      pprPrec p (CompoundLit ty inits loc) =
          pprLoc loc $
          parensIf (p > memberPrec) $
          parens (ppr ty) <+>
          braces (commasep (map pprInit inits))
        where
          pprInit :: (Maybe Designation, Initializer) -> Doc
          pprInit (Nothing, ini) = ppr ini
          pprInit (Just d, ini)  = ppr d <+> text "=" <+/> ppr ini
  
      pprPrec _ (StmExpr blockItems loc) =
          pprLoc loc $ parens $
          ppr blockItems
  
      pprPrec _ (BuiltinVaArg e ty loc) =
          pprLoc loc $
          text "__builtin_va_arg(" <> ppr e <> comma <+> ppr ty <> rparen
  
      pprPrec _ (BlockLit ty attrs block loc) =
          pprLoc loc $
          char '^' <> ppr ty <>
          (if null attrs then empty else softline <> ppr attrs) <+>
          ppr block
  
      pprPrec p (CudaCall f config args loc) =
          pprLoc loc $
          parensIf (p > memberPrec) $
          pprPrec memberPrec f <>
          text "<<<" <> pprConfig config <> text ">>>" <>
          parensList (map ppr args)
        where
          pprConfig :: ExeConfig -> Doc
          pprConfig conf = commasep $
              [ppr (exeGridDim conf), ppr (exeBlockDim conf)] ++
              (case exeSharedSize conf of
                 Nothing -> []
                 Just e -> [ppr e])
              ++
              (case exeStream conf of
                 Nothing -> []
                 Just e -> [ppr e])
  
      pprPrec _ (ObjCMsg recv args varArgs loc1) =
          pprLoc loc1 $
          brackets $
          ppr recv <+/>
          nest 2 (pprMsgArgs args)
        where
          pprMsgArgs ([ObjCArg (Just sel) Nothing loc]) = pprLoc loc $ ppr sel
          pprMsgArgs _                                  = sep (map pprMsgArg args) <>
                                                          cat (map pprVarArg varArgs)
  
          pprMsgArg (ObjCArg (Just sel) (Just e) loc) = pprLoc loc $ ppr sel <> colon <+> ppr e
          pprMsgArg (ObjCArg Nothing    (Just e) loc) = pprLoc loc $ colon <+> ppr e
          pprMsgArg (ObjCArg _          Nothing  loc)
            = error $ "pretty printing 'ObjCArg': missing expression at " ++ show loc
          pprMsgArg (AntiObjCArg v _)  = pprAnti "kwarg" v
          pprMsgArg (AntiObjCArgs v _) = pprAnti "kwargs" v
  
          pprVarArg e = comma <+> ppr e
  
      pprPrec _ (ObjCLitConst op c loc) =
          srcloc loc <>
          char '@' <>
          maybe empty ppr op <>
          ppr c
  
      pprPrec _ (ObjCLitString strs loc) =
          srcloc loc <>
          spread (map ((char '@' <>) . ppr) strs)
  
      pprPrec _ (ObjCLitBool False loc) =
          srcloc loc <>
          text "@NO"
  
      pprPrec _ (ObjCLitBool True loc) =
          srcloc loc <>
          text "@YES"
  
      pprPrec _ (ObjCLitArray es loc) =
          srcloc loc <>
          char '@' <> brackets
            (commasep (map ppr es))
  
      pprPrec _ (ObjCLitDict as loc) =
          srcloc loc <>
          char '@' <> braces
            (commasep (map ppr as))
  
      pprPrec _ (ObjCLitBoxed e loc) =
          srcloc loc <>
          char '@' <> parens (ppr e)
  
      pprPrec _ (ObjCEncode t loc) =
          srcloc loc <>
          text "@encode" <> parens (ppr t)
  
      pprPrec _ (ObjCProtocol ident loc) =
          srcloc loc <>
          text "@protocol" <> parens (ppr ident)
  
      pprPrec _ (ObjCSelector sel loc) =
          srcloc loc <>
          text "@selector" <> parens (text sel)
  
      pprPrec _ (Lambda captureList decl blockItems loc) =
          srcloc loc <>
          ppr captureList <>
          ppr decl <>
          ppr blockItems
  
      pprPrec _ (AntiArgs v _)  = pprAnti "args"  v
  
      pprPrec _ (AntiExp v _)   = pprAnti "var"  v
  
  instance Pretty LambdaDeclarator where
      pprPrec _ (LambdaDeclarator params isMutable returnType _) =
          parens (ppr params) <>
          (if isMutable then text "mutable" else empty) <>
          (if isJust returnType then text "->" <> ppr returnType else empty)
  
  instance Pretty LambdaIntroducer where
      pprPrec _ (LambdaIntroducer items loc) = pprLoc loc $ brackets $ commasep (map ppr items)
  
  instance Pretty CaptureListEntry where
      pprPrec _ DefaultByValue = char '='
      pprPrec _ DefaultByReference = char '&'
  
  instance Pretty ObjCDictElem where
      pprPrec _ (ObjCDictElem l r _)    = ppr l <+> colon <+> ppr r
      pprPrec _ (AntiObjCDictElems v _) = pprAnti "dictelems" v
  
  instance Pretty BinOp where
      ppr Add  = text "+"
      ppr Sub  = text "-"
      ppr Mul  = text "*"
      ppr Div  = text "/"
      ppr Mod  = text "%"
      ppr Eq   = text "=="
      ppr Ne   = text "!="
      ppr Lt   = text "<"
      ppr Gt   = text ">"
      ppr Le   = text "<="
      ppr Ge   = text ">="
      ppr Land = text "&&"
      ppr Lor  = text "||"
      ppr And  = text "&"
      ppr Or   = text "|"
      ppr Xor  = text "^"
      ppr Lsh  = text "<<"
      ppr Rsh  = text ">>"
  
  instance Pretty AssignOp where
      ppr JustAssign = text "="
      ppr AddAssign  = text "+="
      ppr SubAssign  = text "-="
      ppr MulAssign  = text "*="
      ppr DivAssign  = text "/="
      ppr ModAssign  = text "%="
      ppr LshAssign  = text "<<="
      ppr RshAssign  = text ">>="
      ppr AndAssign  = text "&="
      ppr XorAssign  = text "^="
      ppr OrAssign   = text "|="
  
  instance Pretty UnOp where
      ppr AddrOf   = text "&"
      ppr Deref    = text "*"
      ppr Positive = text "+"
      ppr Negate   = text "-"
      ppr Not      = text "~"
      ppr Lnot     = text "!"
  
  instance Pretty AsmOut where
      ppr (AsmOut Nothing constraint ident) =
          text constraint <+> parens (ppr ident)
  
      ppr (AsmOut (Just sym) constraint ident) =
          brackets (ppr sym) <+> text constraint <+> parens (ppr ident)
  
      pprList []   = empty
      pprList outs = commasep (map ppr outs)
  
  instance Pretty AsmIn where
      ppr (AsmIn Nothing constraint e) =
          text constraint <+> parens (ppr e)
  
      ppr (AsmIn (Just sym) constraint e) =
          brackets (ppr sym) <+> text constraint <+> parens (ppr e)
  
      pprList []  = empty
      pprList ins = commasep (map ppr ins)
  
  instance Pretty BlockType where
      ppr (BlockVoid _loc)        = empty
      ppr (BlockParam params loc) = pprLoc loc $ parens (commasep (map ppr params))
      ppr (BlockType ty loc)      = pprLoc loc $ ppr ty
  
  instance Pretty ObjCIvarDecl where
      ppr (ObjCIvarVisi visi  loc) = pprLoc loc $ ppr visi
      ppr (ObjCIvarDecl field loc) = pprLoc loc $ ppr field <> semi
  
  instance Pretty ObjCVisibilitySpec where
      ppr (ObjCPrivate _loc)   = text "@private"
      ppr (ObjCPublic _loc)    = text "@public"
      ppr (ObjCProtected _loc) = text "@protected"
      ppr (ObjCPackage _loc)   = text "@package"
  
  instance Pretty ObjCIfaceDecl where
      ppr (ObjCIfaceProp attrs field loc) =
          pprLoc loc $
          text "@property"
          <+> case attrs of
                [] -> empty
                _  -> parensList (map ppr attrs) <> space
          <> ppr field
          <> semi
      ppr (ObjCIfaceReq req loc) =
          pprLoc loc $ ppr req
      ppr (ObjCIfaceMeth proto _loc) =
          ppr proto <> semi
      ppr (ObjCIfaceDecl decl loc) =
          pprLoc loc $ ppr decl
      ppr (AntiObjCIfaceDecl v _loc) =
          pprAnti "ifdecl" v
      ppr (AntiObjCIfaceDecls v _loc) =
          pprAnti "ifdecls" v
  
      ppr (AntiObjCProp v _)  = pprAnti "prop" v
      ppr (AntiObjCProps v _) = pprAnti "props" v
  
  instance Pretty ObjCPropAttr where
      ppr (ObjCGetter ident loc)     = pprLoc loc $ text "getter=" <> ppr ident
      ppr (ObjCSetter ident loc)     = pprLoc loc $ text "setter=" <> ppr ident <> colon
      ppr (ObjCReadonly loc)         = pprLoc loc $ text "readonly"
      ppr (ObjCReadwrite loc)        = pprLoc loc $ text "readwrite"
      ppr (ObjCAssign loc)           = pprLoc loc $ text "assign"
      ppr (ObjCRetain loc)           = pprLoc loc $ text "retain"
      ppr (ObjCCopy loc)             = pprLoc loc $ text "copy"
      ppr (ObjCNonatomic loc)        = pprLoc loc $ text "nonatomic"
      ppr (ObjCAtomic loc)           = pprLoc loc $ text "atomic"
      ppr (ObjCStrong loc)           = pprLoc loc $ text "strong"
      ppr (ObjCWeak loc)             = pprLoc loc $ text "weak"
      ppr (ObjCUnsafeUnretained loc) = pprLoc loc $ text "unsafe_unretained"
      ppr (AntiObjCAttr v _)         = pprAnti "propattr" v
      ppr (AntiObjCAttrs v _)        = pprAnti "propattrs" v
  
  instance Pretty ObjCMethodReq where
      ppr (ObjCRequired _loc) = text "@required"
      ppr (ObjCOptional _loc) = text "@optional"
  
  instance Pretty ObjCParam where
      ppr (ObjCParam sel ty attrs arg loc) =
          pprLoc loc $
          case (sel, arg) of
           (Nothing , Nothing) -> error $ "pretty printing 'ObjCParam': empty " ++ show loc
           (Just sid, Nothing) -> ppr sid
           (_       , Just pid)
             -> maybe empty ppr sel <> colon <> maybe empty (parens . ppr) ty <> ppr attrs <> ppr pid
      ppr (AntiObjCParam p _)  = pprAnti "methparam" p
      ppr (AntiObjCParams v _) = pprAnti "methparams" v
  
  instance Pretty ObjCMethodProto where
      ppr (ObjCMethodProto isClassMeth resTy attrs1 params vargs attrs2 loc) =
          pprLoc loc $
          (if isClassMeth then char '+' else char '-') <+>
          maybe empty (parens . ppr) resTy <+>
          ppr attrs1 <+>
          spread (map ppr params) <>
          (if vargs then text ", ..." else empty) <+>
          ppr attrs2
      ppr (AntiObjCMethodProto p _) = pprAnti "methproto" p
  
  instance Pretty ObjCCatch where
      ppr (ObjCCatch Nothing     block loc)  =
          srcloc loc <>
          text "@catch (...)" <+> ppr block
  
      ppr (ObjCCatch (Just param) block loc) =
          srcloc loc <>
          text "@catch" <+> parens (ppr param) <+> ppr block
  
      pprList = stack . map ppr
  
  instance Pretty ObjCRecv where
      ppr (ObjCRecvSuper loc) = pprLoc loc $ text "super"
      ppr (ObjCRecvExp e loc) = pprLoc loc $ ppr e
      ppr (AntiObjCRecv v _)  = pprAnti "recv" v
  