{-# LANGUAGE CPP #-}
--  C->Haskell Compiler: pretty printing of C abstract syntax
--
--  Author : Manuel M T Chakravarty
--  Created: 25 August 1
--
--  Version $Revision: 1.3 $ from $Date: 2005/06/22 16:01:21 $
--
--  Copyright (c) [2001..2004] Manuel M T Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  Pretty printing support for abstract C trees.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--- TODO ----------------------------------------------------------------------
--
--  * So far, only covers a small fraction of the abstract tree definition
--

module CPretty (
  -- we are just providing instances to the class `Pretty'
) where

#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif
import Idents (Ident, identToLexeme)
import Text.PrettyPrint.HughesPJ

import CAST


-- pretty printing of AST nodes
-- ----------------------------

instance Show CDecl where
  showsPrec :: Int -> CDecl -> ShowS
showsPrec Int
_ = String -> ShowS
showString (String -> ShowS) -> (CDecl -> String) -> CDecl -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> String) -> (CDecl -> Doc) -> CDecl -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDecl -> Doc
forall a. Pretty a => a -> Doc
pretty

-- overloaded pretty-printing function (EXPORTED)
--
class Pretty a where
  pretty     :: a -> Doc
  prettyPrec :: Int -> a -> Doc

  pretty       = Int -> a -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
0
  prettyPrec Int
_ = a -> Doc
forall a. Pretty a => a -> Doc
pretty


-- actual structure tree traversals
-- --------------------------------

instance Pretty CDecl where
  pretty :: CDecl -> Doc
pretty (CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
declrs Attrs
_) =
    [Doc] -> Doc
hsep ((CDeclSpec -> Doc) -> [CDeclSpec] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map CDeclSpec -> Doc
forall a. Pretty a => a -> Doc
pretty [CDeclSpec]
specs) Doc -> Int -> Doc -> Doc
`hang` Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma (((Maybe CDeclr, Maybe CInit, Maybe CExpr) -> Doc)
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe CDeclr, Maybe CInit, Maybe CExpr) -> Doc
prettyDeclr [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
declrs)) Doc -> Doc -> Doc
<> Doc
semi

instance Pretty CDeclSpec where
  pretty :: CDeclSpec -> Doc
pretty (CStorageSpec CStorageSpec
sspec) = CStorageSpec -> Doc
forall a. Pretty a => a -> Doc
pretty CStorageSpec
sspec
  pretty (CTypeSpec    CTypeSpec
tspec) = CTypeSpec -> Doc
forall a. Pretty a => a -> Doc
pretty CTypeSpec
tspec
  pretty (CTypeQual    CTypeQual
qspec) = CTypeQual -> Doc
forall a. Pretty a => a -> Doc
pretty CTypeQual
qspec

instance Pretty CStorageSpec where
  pretty :: CStorageSpec -> Doc
pretty (CAuto     Attrs
_) = String -> Doc
text String
"auto"
  pretty (CRegister Attrs
_) = String -> Doc
text String
"register"
  pretty (CStatic   Attrs
_) = String -> Doc
text String
"static"
  pretty (CExtern   Attrs
_) = String -> Doc
text String
"extern"
  pretty (CTypedef  Attrs
_) = String -> Doc
text String
"typedef"

instance Pretty CTypeSpec where
  pretty :: CTypeSpec -> Doc
pretty (CVoidType      Attrs
_) = String -> Doc
text String
"void"
  pretty (CCharType      Attrs
_) = String -> Doc
text String
"char"
  pretty (CShortType     Attrs
_) = String -> Doc
text String
"short"
  pretty (CIntType       Attrs
_) = String -> Doc
text String
"int"
  pretty (CLongType      Attrs
_) = String -> Doc
text String
"long"
  pretty (CFloatType     Attrs
_) = String -> Doc
text String
"float"
  pretty (CFloat128Type  Attrs
_) = String -> Doc
text String
"__float128"
  pretty (CDoubleType    Attrs
_) = String -> Doc
text String
"double"
  pretty (CSignedType    Attrs
_) = String -> Doc
text String
"signed"
  pretty (CUnsigType     Attrs
_) = String -> Doc
text String
"unsigned"
  pretty (CSUType CStructUnion
struct Attrs
_) = String -> Doc
text String
"<<CPretty: CSUType not yet implemented!>>"
  pretty (CEnumType CEnum
enum Attrs
_) = String -> Doc
text String
"<<CPretty: CEnumType not yet implemented!>>"
  pretty (CTypeDef Ident
ide   Attrs
_) = Ident -> Doc
ident Ident
ide

instance Pretty CTypeQual where
  pretty :: CTypeQual -> Doc
pretty (CConstQual Attrs
_) = String -> Doc
text String
"const"
  pretty (CVolatQual Attrs
_) = String -> Doc
text String
"volatile"
  pretty (CRestrQual Attrs
_) = String -> Doc
text String
"restrict"

prettyDeclr :: (Maybe CDeclr, Maybe CInit, Maybe CExpr) -> Doc
prettyDeclr :: (Maybe CDeclr, Maybe CInit, Maybe CExpr) -> Doc
prettyDeclr (Maybe CDeclr
odeclr, Maybe CInit
oinit, Maybe CExpr
oexpr) =
      Doc -> (CDeclr -> Doc) -> Maybe CDeclr -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty CDeclr -> Doc
forall a. Pretty a => a -> Doc
pretty Maybe CDeclr
odeclr
  Doc -> Doc -> Doc
<+> Doc -> (CInit -> Doc) -> Maybe CInit -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty ((String -> Doc
text String
"=" Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> (CInit -> Doc) -> CInit -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInit -> Doc
forall a. Pretty a => a -> Doc
pretty) Maybe CInit
oinit
  Doc -> Doc -> Doc
<+> Doc -> (CExpr -> Doc) -> Maybe CExpr -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty ((String -> Doc
text String
":" Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> (CExpr -> Doc) -> CExpr -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty) Maybe CExpr
oexpr

instance Pretty CDeclr where
  pretty :: CDeclr -> Doc
pretty (CVarDeclr Maybe Ident
oide                   Attrs
_) = Doc -> (Ident -> Doc) -> Maybe Ident -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty Ident -> Doc
ident Maybe Ident
oide
  pretty (CPtrDeclr [CTypeQual]
inds CDeclr
declr             Attrs
_) = 
    let
      oneLevel :: [a] -> Doc -> Doc
oneLevel [a]
ind = Doc -> Doc
parens (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Doc] -> Doc
hsep ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
pretty [a]
ind) Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc
text String
"*" Doc -> Doc -> Doc
<>)
    in
    [CTypeQual] -> Doc -> Doc
forall a. Pretty a => [a] -> Doc -> Doc
oneLevel [CTypeQual]
inds (CDeclr -> Doc
forall a. Pretty a => a -> Doc
pretty CDeclr
declr)
  pretty (CArrDeclr CDeclr
declr [CTypeQual]
_ Maybe CExpr
oexpr          Attrs
_) =
    CDeclr -> Doc
forall a. Pretty a => a -> Doc
pretty CDeclr
declr Doc -> Doc -> Doc
<> Doc -> Doc
brackets (Doc -> (CExpr -> Doc) -> Maybe CExpr -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty Maybe CExpr
oexpr)
  pretty (CFunDeclr CDeclr
declr [CDecl]
decls Bool
isVariadic Attrs
_) =
    let
      varDoc :: Doc
varDoc = if Bool
isVariadic then String -> Doc
text String
", ..." else Doc
empty
    in
    CDeclr -> Doc
forall a. Pretty a => a -> Doc
pretty CDeclr
declr 
    Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((CDecl -> Doc) -> [CDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map CDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [CDecl]
decls)) Doc -> Doc -> Doc
<> Doc
varDoc)

instance Pretty CInit where
  pretty :: CInit -> Doc
pretty CInit
_ = String -> Doc
text String
"<<CPretty: CInit not yet implemented!>>"

instance Pretty CExpr where
  pretty :: CExpr -> Doc
pretty CExpr
_ = String -> Doc
text String
"<<CPretty: CExpr not yet implemented!>>"


-- auxilliary functions
-- --------------------

ident :: Ident -> Doc
ident :: Ident -> Doc
ident  = String -> Doc
text (String -> Doc) -> (Ident -> String) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> String
identToLexeme