--------------------------------------------------------------------------------
--                                                                  2016.09.08
-- |
-- Module      :  Language.Hakaru.CodeGen.Pretty
-- Copyright   :  Copyright (c) 2016 the Hakaru team
-- License     :  BSD3
-- Maintainer  :  zsulliva@indiana.edu
-- Stability   :  experimental
-- Portability :  GHC-only
--
--   A pretty printer for the CodeGen AST
--
--------------------------------------------------------------------------------

module Language.Hakaru.CodeGen.Pretty
  ( pretty
  , prettyPrint
  , Pretty
  ) where

import Prelude hiding ((<>))
import Text.PrettyPrint
import Language.Hakaru.CodeGen.AST

prettyPrint :: Pretty a => a -> String
prettyPrint :: a -> String
prettyPrint = Doc -> String
render (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Pretty a => a -> Doc
pretty

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

mpretty :: Pretty a => Maybe a -> Doc
mpretty :: Maybe a -> Doc
mpretty Maybe a
Nothing  = Doc
empty
mpretty (Just a
x) = a -> Doc
forall a. Pretty a => a -> Doc
pretty a
x

mPrettyPrec :: Pretty a => Int -> Maybe a -> Doc
mPrettyPrec :: Int -> Maybe a -> Doc
mPrettyPrec Int
_ Maybe a
Nothing  = Doc
empty
mPrettyPrec Int
p (Just a
x) = Int -> a -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
p a
x

-- will compare two precs and put parens if the prec is lower
parensPrec :: Int -> Int -> Doc -> Doc
parensPrec :: Int -> Int -> Doc -> Doc
parensPrec Int
x Int
y = if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
y then Doc -> Doc
parens else Doc -> Doc
forall a. a -> a
id

emptyText :: Doc
emptyText :: Doc
emptyText = String -> Doc
text String
""

instance Pretty a => Pretty (Maybe a) where
  pretty :: Maybe a -> Doc
pretty Maybe a
Nothing  = Doc
empty
  pretty (Just a
x) = a -> Doc
forall a. Pretty a => a -> Doc
pretty a
x


--------------------------------------------------------------------------------
--                                  Top Level                                 --
--------------------------------------------------------------------------------

instance Pretty Ident where
  pretty :: Ident -> Doc
pretty (Ident String
i) = String -> Doc
text String
i

instance Pretty CAST where
  pretty :: CAST -> Doc
pretty (CAST [CExtDecl]
extdecls) = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([CExtDecl] -> [Doc]) -> [CExtDecl] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CExtDecl -> Doc) -> [CExtDecl] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CExtDecl -> Doc
forall a. Pretty a => a -> Doc
pretty ([CExtDecl] -> Doc) -> [CExtDecl] -> Doc
forall a b. (a -> b) -> a -> b
$ [CExtDecl]
extdecls

instance Pretty CExtDecl where
  pretty :: CExtDecl -> Doc
pretty (CDeclExt CDecl
d) = Doc
emptyText Doc -> Doc -> Doc
$+$ CDecl -> Doc
forall a. Pretty a => a -> Doc
pretty CDecl
d Doc -> Doc -> Doc
<> Doc
semi
  pretty (CFunDefExt CFunDef
f) = Doc
emptyText Doc -> Doc -> Doc
$+$ CFunDef -> Doc
forall a. Pretty a => a -> Doc
pretty CFunDef
f
  pretty (CCommentExt String
s) = String -> Doc
text String
"/*" Doc -> Doc -> Doc
<+> String -> Doc
text String
s Doc -> Doc -> Doc
<+> String -> Doc
text String
"*/"
  pretty (CPPExt Preprocessor
p) = Preprocessor -> Doc
forall a. Pretty a => a -> Doc
pretty Preprocessor
p

instance Pretty CFunDef where
  pretty :: CFunDef -> Doc
pretty (CFunDef [CDeclSpec]
dspecs CDeclr
dr [CDecl]
ds CStat
s) =
    (([Doc] -> Doc
hsep ([Doc] -> Doc) -> ([CDeclSpec] -> [Doc]) -> [CDeclSpec] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CDeclSpec -> Doc) -> [CDeclSpec] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CDeclSpec -> Doc
forall a. Pretty a => a -> Doc
pretty ([CDeclSpec] -> Doc) -> [CDeclSpec] -> Doc
forall a b. (a -> b) -> a -> b
$ [CDeclSpec]
dspecs)
     Doc -> Doc -> Doc
<+> CDeclr -> Doc
forall a. Pretty a => a -> Doc
pretty CDeclr
dr
     Doc -> Doc -> Doc
<>  (Doc -> Doc
parens (Doc -> Doc) -> ([CDecl] -> Doc) -> [CDecl] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([CDecl] -> [Doc]) -> [CDecl] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([CDecl] -> [Doc]) -> [CDecl] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CDecl -> Doc) -> [CDecl] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CDecl -> Doc
forall a. Pretty a => a -> Doc
pretty ([CDecl] -> Doc) -> [CDecl] -> Doc
forall a b. (a -> b) -> a -> b
$ [CDecl]
ds))
    Doc -> Doc -> Doc
$+$ (CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
s)

--------------------------------------------------------------------------------
--                               Preprocessor                                 --
--------------------------------------------------------------------------------

instance Pretty Preprocessor where
  pretty :: Preprocessor -> Doc
pretty (PPDefine String
n String
x) = [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([String] -> [Doc]) -> [String] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc) -> [String] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Doc
text ([String] -> Doc) -> [String] -> Doc
forall a b. (a -> b) -> a -> b
$ [String
"#define",String
n,String
x]
  pretty (PPInclude String
s) = String -> Doc
text String
"#include" Doc -> Doc -> Doc
<+> String -> Doc
text String
"<" Doc -> Doc -> Doc
<> String -> Doc
text String
s Doc -> Doc -> Doc
<> String -> Doc
text String
">"
  pretty (PPUndef String
s) = String -> Doc
text String
"#undef" Doc -> Doc -> Doc
<+> String -> Doc
text String
s
  pretty (PPIf String
s) = String -> Doc
text String
"#if" Doc -> Doc -> Doc
<+> String -> Doc
text String
s
  pretty (PPIfDef String
s) = String -> Doc
text String
"#ifdef" Doc -> Doc -> Doc
<+> String -> Doc
text String
s
  pretty (PPIfNDef String
s) = String -> Doc
text String
"#ifndef" Doc -> Doc -> Doc
<+> String -> Doc
text String
s
  pretty (PPElse String
s) = String -> Doc
text String
"#else" Doc -> Doc -> Doc
<+> String -> Doc
text String
s
  pretty (PPElif String
s) = String -> Doc
text String
"#elif" Doc -> Doc -> Doc
<+> String -> Doc
text String
s
  pretty (PPEndif String
s) = String -> Doc
text String
"#endif" Doc -> Doc -> Doc
<+> String -> Doc
text String
s
  pretty (PPError String
s) = String -> Doc
text String
"#error" Doc -> Doc -> Doc
<+> String -> Doc
text String
s
  pretty (PPPragma [String]
ts) = Doc
space Doc -> Doc -> Doc
$$ String -> Doc
text String
"#pragma" Doc -> Doc -> Doc
<+> ([Doc] -> Doc
hsep ([Doc] -> Doc) -> ([String] -> [Doc]) -> [String] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc) -> [String] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Doc
text ([String] -> Doc) -> [String] -> Doc
forall a b. (a -> b) -> a -> b
$ [String]
ts)


--------------------------------------------------------------------------------
--                             CDeclarations                                  --
--------------------------------------------------------------------------------

instance Pretty CDecl where
  pretty :: CDecl -> Doc
pretty (CDecl [CDeclSpec]
ds [(CDeclr, Maybe CInit)]
ps) =
    [Doc] -> Doc
hsep [ [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([CDeclSpec] -> [Doc]) -> [CDeclSpec] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CDeclSpec -> Doc) -> [CDeclSpec] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CDeclSpec -> Doc
forall a. Pretty a => a -> Doc
pretty ([CDeclSpec] -> Doc) -> [CDeclSpec] -> Doc
forall a b. (a -> b) -> a -> b
$ [CDeclSpec]
ds
         , [Doc] -> Doc
hsep ([Doc] -> Doc)
-> ([(CDeclr, Maybe CInit)] -> [Doc])
-> [(CDeclr, Maybe CInit)]
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc])
-> ([(CDeclr, Maybe CInit)] -> [Doc])
-> [(CDeclr, Maybe CInit)]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CDeclr, Maybe CInit) -> Doc) -> [(CDeclr, Maybe CInit)] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CDeclr, Maybe CInit) -> Doc
forall a a. (Pretty a, Pretty a) => (a, Maybe a) -> Doc
declarators ([(CDeclr, Maybe CInit)] -> Doc) -> [(CDeclr, Maybe CInit)] -> Doc
forall a b. (a -> b) -> a -> b
$ [(CDeclr, Maybe CInit)]
ps]
    where declarators :: (a, Maybe a) -> Doc
declarators (a
dr, Maybe a
Nothing) = a -> Doc
forall a. Pretty a => a -> Doc
pretty a
dr
          declarators (a
dr, Just a
ilist) = a -> Doc
forall a. Pretty a => a -> Doc
pretty a
dr Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> a -> Doc
forall a. Pretty a => a -> Doc
pretty a
ilist

instance Pretty CDeclr where
  pretty :: CDeclr -> Doc
pretty (CDeclr Maybe CPtrDeclr
mp CDirectDeclr
dd) =
    Maybe CPtrDeclr -> Doc
forall a. Pretty a => Maybe a -> Doc
mpretty Maybe CPtrDeclr
mp Doc -> Doc -> Doc
<+> (CDirectDeclr -> Doc
forall a. Pretty a => a -> Doc
pretty (CDirectDeclr -> Doc) -> CDirectDeclr -> Doc
forall a b. (a -> b) -> a -> b
$ CDirectDeclr
dd)

instance Pretty CPtrDeclr where
  pretty :: CPtrDeclr -> Doc
pretty (CPtrDeclr [CTypeQual]
ts) = String -> Doc
text String
"*" Doc -> Doc -> Doc
<+> ([Doc] -> Doc
hsep ([Doc] -> Doc) -> ([CTypeQual] -> [Doc]) -> [CTypeQual] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CTypeQual -> Doc) -> [CTypeQual] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CTypeQual -> Doc
forall a. Pretty a => a -> Doc
pretty ([CTypeQual] -> Doc) -> [CTypeQual] -> Doc
forall a b. (a -> b) -> a -> b
$ [CTypeQual]
ts)

instance Pretty CDirectDeclr where
  pretty :: CDirectDeclr -> Doc
pretty (CDDeclrIdent Ident
i) = Ident -> Doc
forall a. Pretty a => a -> Doc
pretty Ident
i
  pretty (CDDeclrArr CDirectDeclr
dd Maybe CExpr
e) = CDirectDeclr -> Doc
forall a. Pretty a => a -> Doc
pretty CDirectDeclr
dd Doc -> Doc -> Doc
<+> (Doc -> Doc
brackets (Doc -> Doc) -> (Maybe CExpr -> Doc) -> Maybe CExpr -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty (Maybe CExpr -> Doc) -> Maybe CExpr -> Doc
forall a b. (a -> b) -> a -> b
$ Maybe CExpr
e)
  pretty (CDDeclrFun CDirectDeclr
dd [[CTypeSpec]]
ts) =
    CDirectDeclr -> Doc
forall a. Pretty a => a -> Doc
pretty CDirectDeclr
dd Doc -> Doc -> Doc
<> (Doc -> Doc
parens (Doc -> Doc) -> ([[CTypeSpec]] -> Doc) -> [[CTypeSpec]] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([[CTypeSpec]] -> [Doc]) -> [[CTypeSpec]] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc])
-> ([[CTypeSpec]] -> [Doc]) -> [[CTypeSpec]] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CTypeSpec] -> Doc) -> [[CTypeSpec]] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Doc] -> Doc
hsep ([Doc] -> Doc) -> ([CTypeSpec] -> [Doc]) -> [CTypeSpec] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CTypeSpec -> Doc) -> [CTypeSpec] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CTypeSpec -> Doc
forall a. Pretty a => a -> Doc
pretty) ([[CTypeSpec]] -> Doc) -> [[CTypeSpec]] -> Doc
forall a b. (a -> b) -> a -> b
$ [[CTypeSpec]]
ts)
  pretty (CDDeclrRec CDeclr
declr) = Doc -> Doc
parens (Doc -> Doc) -> (CDeclr -> Doc) -> CDeclr -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDeclr -> Doc
forall a. Pretty a => a -> Doc
pretty (CDeclr -> Doc) -> CDeclr -> Doc
forall a b. (a -> b) -> a -> b
$ CDeclr
declr


instance Pretty CDeclSpec where
  pretty :: CDeclSpec -> Doc
pretty (CStorageSpec CStorageSpec
ss) = CStorageSpec -> Doc
forall a. Pretty a => a -> Doc
pretty CStorageSpec
ss
  pretty (CTypeSpec CTypeSpec
ts) = CTypeSpec -> Doc
forall a. Pretty a => a -> Doc
pretty CTypeSpec
ts
  pretty (CTypeQual CTypeQual
tq) = CTypeQual -> Doc
forall a. Pretty a => a -> Doc
pretty CTypeQual
tq
  pretty (CFunSpec CFunSpec
_ ) = String -> Doc
text String
"inline"  -- inline is the only CFunSpec

instance Pretty CStorageSpec where
  pretty :: CStorageSpec -> Doc
pretty CStorageSpec
CTypeDef = String -> Doc
text String
"typedef"
  pretty CStorageSpec
CExtern = String -> Doc
text String
"extern"
  pretty CStorageSpec
CStatic = String -> Doc
text String
"static"
  pretty CStorageSpec
CAuto = String -> Doc
text String
"auto"
  pretty CStorageSpec
CRegister = String -> Doc
text String
"register"

instance Pretty CTypeQual where
  pretty :: CTypeQual -> Doc
pretty CTypeQual
CConstQual = String -> Doc
text String
"const"
  pretty CTypeQual
CVolatQual = String -> Doc
text String
"volatile"

instance Pretty CTypeSpec where
  pretty :: CTypeSpec -> Doc
pretty CTypeSpec
CVoid = String -> Doc
text String
"void"
  pretty CTypeSpec
CChar = String -> Doc
text String
"char"
  pretty CTypeSpec
CShort = String -> Doc
text String
"short"
  pretty CTypeSpec
CInt = String -> Doc
text String
"int"
  pretty CTypeSpec
CLong = String -> Doc
text String
"long"
  pretty CTypeSpec
CFloat = String -> Doc
text String
"float"
  pretty CTypeSpec
CDouble = String -> Doc
text String
"double"
  pretty CTypeSpec
CSigned = String -> Doc
text String
"signed"
  pretty CTypeSpec
CUnsigned = String -> Doc
text String
"unsigned"
  pretty (CSUType CSUSpec
cs) = CSUSpec -> Doc
forall a. Pretty a => a -> Doc
pretty CSUSpec
cs
  pretty (CTypeDefType Ident
sid) = Ident -> Doc
forall a. Pretty a => a -> Doc
pretty Ident
sid
  pretty (CEnumType CEnum
_) = String -> Doc
forall a. HasCallStack => String -> a
error String
"TODO: Pretty EnumType"

instance Pretty CTypeName where
  pretty :: CTypeName -> Doc
pretty (CTypeName [CTypeSpec]
tspecs Bool
pb) =
    let ss :: Doc
ss = [Doc] -> Doc
sep ([Doc] -> Doc) -> ([CTypeSpec] -> [Doc]) -> [CTypeSpec] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CTypeSpec -> Doc) -> [CTypeSpec] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CTypeSpec -> Doc
forall a. Pretty a => a -> Doc
pretty ([CTypeSpec] -> Doc) -> [CTypeSpec] -> Doc
forall a b. (a -> b) -> a -> b
$ [CTypeSpec]
tspecs
    in if Bool
pb
       then Doc
ss Doc -> Doc -> Doc
<+> String -> Doc
text String
"*"
       else Doc
ss

instance Pretty CSUSpec where
  pretty :: CSUSpec -> Doc
pretty (CSUSpec CSUTag
tag Maybe Ident
mi []) =
    CSUTag -> Doc
forall a. Pretty a => a -> Doc
pretty CSUTag
tag Doc -> Doc -> Doc
<+> Maybe Ident -> Doc
forall a. Pretty a => Maybe a -> Doc
mpretty Maybe Ident
mi
  pretty (CSUSpec CSUTag
tag Maybe Ident
mi [CDecl]
ds) =
    (CSUTag -> Doc
forall a. Pretty a => a -> Doc
pretty CSUTag
tag Doc -> Doc -> Doc
<+> Maybe Ident -> Doc
forall a. Pretty a => a -> Doc
pretty Maybe Ident
mi)
    Doc -> Doc -> Doc
$+$ (   Doc
lbrace
        Doc -> Doc -> Doc
$+$ (Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> ([CDecl] -> Doc) -> [CDecl] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
sep ([Doc] -> Doc) -> ([CDecl] -> [Doc]) -> [CDecl] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CDecl -> Doc) -> [CDecl] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\CDecl
d -> CDecl -> Doc
forall a. Pretty a => a -> Doc
pretty CDecl
d Doc -> Doc -> Doc
<> Doc
semi) ([CDecl] -> Doc) -> [CDecl] -> Doc
forall a b. (a -> b) -> a -> b
$ [CDecl]
ds)
        Doc -> Doc -> Doc
$+$ Doc
rbrace )

instance Pretty CSUTag where
  pretty :: CSUTag -> Doc
pretty CSUTag
CStructTag = String -> Doc
text String
"struct"
  pretty CSUTag
CUnionTag = String -> Doc
text String
"union"

instance Pretty CEnum where
  pretty :: CEnum -> Doc
pretty (CEnum Maybe Ident
_ [(Ident, Maybe CExpr)]
_) = String -> Doc
forall a. HasCallStack => String -> a
error String
"TODO: Pretty Enum"

instance Pretty CInit where
  pretty :: CInit -> Doc
pretty (CInitExpr CExpr
_) = String -> Doc
forall a. HasCallStack => String -> a
error String
"TODO: Pretty Init"
  pretty (CInitList [([CPartDesig], CInit)]
_) = String -> Doc
forall a. HasCallStack => String -> a
error String
"TODO: Pretty Init list"

instance Pretty CPartDesig where
  pretty :: CPartDesig -> Doc
pretty (CArrDesig CExpr
_) = String -> Doc
forall a. HasCallStack => String -> a
error String
"TODO: Pretty Arr Desig"
  pretty (CMemberDesig CExpr
_) = String -> Doc
forall a. HasCallStack => String -> a
error String
"TODO: Pretty Memdesig"


--------------------------------------------------------------------------------
--                                CStatements                                 --
--------------------------------------------------------------------------------

instance Pretty CStat where
  pretty :: CStat -> Doc
pretty (CLabel Ident
lId CStat
s) = Ident -> Doc
forall a. Pretty a => a -> Doc
pretty Ident
lId Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 (CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
s)
  pretty (CGoto Ident
lId) = String -> Doc
text String
"goto" Doc -> Doc -> Doc
<+> Ident -> Doc
forall a. Pretty a => a -> Doc
pretty Ident
lId Doc -> Doc -> Doc
<> Doc
semi
  pretty (CSwitch CExpr
e CStat
s) = String -> Doc
text String
"switch" Doc -> Doc -> Doc
<+> CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
e Doc -> Doc -> Doc
<+> (Doc -> Doc
parens (Doc -> Doc) -> (CStat -> Doc) -> CStat -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CStat -> Doc
forall a. Pretty a => a -> Doc
pretty (CStat -> Doc) -> CStat -> Doc
forall a b. (a -> b) -> a -> b
$ CStat
s )
  pretty (CCase CExpr
e CStat
s) = String -> Doc
text String
"case" Doc -> Doc -> Doc
<+> CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
e Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 (CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
s)
  pretty (CDefault CStat
s) = String -> Doc
text String
"default" Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 (CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
s)
  pretty (CExpr Maybe CExpr
me) = Maybe CExpr -> Doc
forall a. Pretty a => Maybe a -> Doc
mpretty Maybe CExpr
me Doc -> Doc -> Doc
<> Doc
semi
  pretty (CCompound [CCompoundBlockItem]
bs) =
    Doc
lbrace Doc -> Doc -> Doc
$+$ (Int -> Doc -> Doc
nest Int
2 (Doc -> Doc)
-> ([CCompoundBlockItem] -> Doc) -> [CCompoundBlockItem] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat ([Doc] -> Doc)
-> ([CCompoundBlockItem] -> [Doc]) -> [CCompoundBlockItem] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CCompoundBlockItem -> Doc) -> [CCompoundBlockItem] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CCompoundBlockItem -> Doc
forall a. Pretty a => a -> Doc
pretty ([CCompoundBlockItem] -> Doc) -> [CCompoundBlockItem] -> Doc
forall a b. (a -> b) -> a -> b
$ [CCompoundBlockItem]
bs) Doc -> Doc -> Doc
$+$ Doc
rbrace

  pretty (CIf CExpr
ce CStat
thns (Just CStat
elss)) =
    String -> Doc
text String
"if" Doc -> Doc -> Doc
<+> (Doc -> Doc
parens (Doc -> Doc) -> (CExpr -> Doc) -> CExpr -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec (-Int
5) (CExpr -> Doc) -> CExpr -> Doc
forall a b. (a -> b) -> a -> b
$ CExpr
ce)
              Doc -> Doc -> Doc
$+$ (CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
thns)
              Doc -> Doc -> Doc
$+$ String -> Doc
text String
"else"
              Doc -> Doc -> Doc
$+$ (CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
elss)
  pretty (CIf CExpr
ce CStat
thns Maybe CStat
Nothing) =
    String -> Doc
text String
"if" Doc -> Doc -> Doc
<+> (Doc -> Doc
parens (Doc -> Doc) -> (CExpr -> Doc) -> CExpr -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec (-Int
5) (CExpr -> Doc) -> CExpr -> Doc
forall a b. (a -> b) -> a -> b
$ CExpr
ce) Doc -> Doc -> Doc
$+$ (CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
thns)

  pretty (CWhile CExpr
ce CStat
s Bool
b) =
    if Bool
b
    then String -> Doc
text String
"do" Doc -> Doc -> Doc
$+$ CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
s Doc -> Doc -> Doc
$+$ (String -> Doc
text String
"while" Doc -> Doc -> Doc
<+> (Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
ce) Doc -> Doc -> Doc
<> Doc
semi)
    else (String -> Doc
text String
"while" Doc -> Doc -> Doc
<+> (Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
ce)) Doc -> Doc -> Doc
$+$ (CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
s)

  pretty (CFor Maybe CExpr
me Maybe CExpr
mce Maybe CExpr
mie CStat
s) =
    String -> Doc
text String
"for"
    Doc -> Doc -> Doc
<+> (Doc -> Doc
parens (Doc -> Doc) -> ([Maybe CExpr] -> Doc) -> [Maybe CExpr] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Maybe CExpr] -> [Doc]) -> [Maybe CExpr] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
semi ([Doc] -> [Doc])
-> ([Maybe CExpr] -> [Doc]) -> [Maybe CExpr] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe CExpr -> Doc) -> [Maybe CExpr] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Maybe CExpr -> Doc
forall a. Pretty a => Int -> Maybe a -> Doc
mPrettyPrec Int
10) ([Maybe CExpr] -> Doc) -> [Maybe CExpr] -> Doc
forall a b. (a -> b) -> a -> b
$ [Maybe CExpr
me,Maybe CExpr
mce,Maybe CExpr
mie])
    Doc -> Doc -> Doc
$$  (CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
s)

  pretty CStat
CCont = String -> Doc
text String
"continue" Doc -> Doc -> Doc
<> Doc
semi
  pretty CStat
CBreak = String -> Doc
text String
"break" Doc -> Doc -> Doc
<> Doc
semi
  pretty (CReturn Maybe CExpr
me) = String -> Doc
text String
"return" Doc -> Doc -> Doc
<+> Maybe CExpr -> Doc
forall a. Pretty a => Maybe a -> Doc
mpretty Maybe CExpr
me  Doc -> Doc -> Doc
<> Doc
semi
  pretty (CComment String
s) = String -> Doc
text String
"/*" Doc -> Doc -> Doc
<+> String -> Doc
text String
s Doc -> Doc -> Doc
<+> String -> Doc
text String
"*/"
  pretty (CPPStat Preprocessor
p) = Preprocessor -> Doc
forall a. Pretty a => a -> Doc
pretty Preprocessor
p

instance Pretty CCompoundBlockItem where
  pretty :: CCompoundBlockItem -> Doc
pretty (CBlockStat CStat
s) = CStat -> Doc
forall a. Pretty a => a -> Doc
pretty CStat
s
  pretty (CBlockDecl CDecl
d) = CDecl -> Doc
forall a. Pretty a => a -> Doc
pretty CDecl
d Doc -> Doc -> Doc
<> Doc
semi


--------------------------------------------------------------------------------
--                                CExpressions                                --
--------------------------------------------------------------------------------

instance Pretty CExpr where
  prettyPrec :: Int -> CExpr -> Doc
prettyPrec Int
_ (CComma [CExpr]
es) = [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([CExpr] -> [Doc]) -> [CExpr] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([CExpr] -> [Doc]) -> [CExpr] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CExpr -> Doc) -> [CExpr] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty ([CExpr] -> Doc) -> [CExpr] -> Doc
forall a b. (a -> b) -> a -> b
$ [CExpr]
es
  prettyPrec Int
_ (CAssign CAssignOp
op CExpr
le CExpr
re) = CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
le Doc -> Doc -> Doc
<+> CAssignOp -> Doc
forall a. Pretty a => a -> Doc
pretty CAssignOp
op Doc -> Doc -> Doc
<+> CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
re
  prettyPrec Int
_ (CCond CExpr
ce CExpr
thn CExpr
els) = CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
ce Doc -> Doc -> Doc
<+> String -> Doc
text String
"?" Doc -> Doc -> Doc
<+> CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
thn Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
els
  prettyPrec Int
p (CBinary CBinaryOp
op CExpr
e1 CExpr
e2) =
    Int -> Int -> Doc -> Doc
parensPrec Int
p Int
0 (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
e1, CBinaryOp -> Doc
forall a. Pretty a => a -> Doc
pretty CBinaryOp
op, CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
e2]
  prettyPrec Int
p (CCast CTypeName
d CExpr
e) =
    Int -> Int -> Doc -> Doc
parensPrec Int
p (Int
2) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
parens (CTypeName -> Doc
forall a. Pretty a => a -> Doc
pretty CTypeName
d) Doc -> Doc -> Doc
<> CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
e
  prettyPrec Int
p (CUnary CUnaryOp
op CExpr
e) =
    if CUnaryOp -> [CUnaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem CUnaryOp
op [CUnaryOp
CPostIncOp,CUnaryOp
CPostDecOp]
    then Int -> Int -> Doc -> Doc
parensPrec Int
p (-Int
1) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> CExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec (-Int
1) CExpr
e Doc -> Doc -> Doc
<> CUnaryOp -> Doc
forall a. Pretty a => a -> Doc
pretty CUnaryOp
op
    else Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ CUnaryOp -> Doc
forall a. Pretty a => a -> Doc
pretty CUnaryOp
op Doc -> Doc -> Doc
<> Int -> CExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec (-Int
1) CExpr
e

  prettyPrec Int
_ (CSizeOfExpr CExpr
e) = String -> Doc
text String
"sizeof" Doc -> Doc -> Doc
<> (Doc -> Doc
parens (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 (CExpr -> Doc) -> CExpr -> Doc
forall a b. (a -> b) -> a -> b
$ CExpr
e)
  prettyPrec Int
_ (CSizeOfType CTypeName
d) = String -> Doc
text String
"sizeof" Doc -> Doc -> Doc
<> (Doc -> Doc
parens (Doc -> Doc) -> (CTypeName -> Doc) -> CTypeName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTypeName -> Doc
forall a. Pretty a => a -> Doc
pretty (CTypeName -> Doc) -> CTypeName -> Doc
forall a b. (a -> b) -> a -> b
$ CTypeName
d)
  prettyPrec Int
_ (CIndex CExpr
arrId CExpr
ie) = CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
arrId Doc -> Doc -> Doc
<> (Doc -> Doc
brackets (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 (CExpr -> Doc) -> CExpr -> Doc
forall a b. (a -> b) -> a -> b
$ CExpr
ie)
  prettyPrec Int
_ (CCall CExpr
fune [CExpr]
es) =
    CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
fune Doc -> Doc -> Doc
<> (Doc -> Doc
parens (Doc -> Doc) -> ([CExpr] -> Doc) -> [CExpr] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hcat ([Doc] -> Doc) -> ([CExpr] -> [Doc]) -> [CExpr] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([CExpr] -> [Doc]) -> [CExpr] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CExpr -> Doc) -> [CExpr] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty ([CExpr] -> Doc) -> [CExpr] -> Doc
forall a b. (a -> b) -> a -> b
$ [CExpr]
es)
  prettyPrec Int
_ (CMember CExpr
ve Ident
memId Bool
isPtr) =
    let op :: Doc
op = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ if Bool
isPtr then String
"." else String
"->"
    in  CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty CExpr
ve Doc -> Doc -> Doc
<> Doc
op Doc -> Doc -> Doc
<> Ident -> Doc
forall a. Pretty a => a -> Doc
pretty Ident
memId
  prettyPrec Int
_ (CVar Ident
varId) = Ident -> Doc
forall a. Pretty a => a -> Doc
pretty Ident
varId
  prettyPrec Int
_ (CConstant CConst
c) = CConst -> Doc
forall a. Pretty a => a -> Doc
pretty CConst
c
  prettyPrec Int
_ (CCompoundLit CDecl
d CInit
ini) = Doc -> Doc
parens (CDecl -> Doc
forall a. Pretty a => a -> Doc
pretty CDecl
d) Doc -> Doc -> Doc
<> CInit -> Doc
forall a. Pretty a => a -> Doc
pretty CInit
ini


instance Pretty CAssignOp where
  pretty :: CAssignOp -> Doc
pretty CAssignOp
CAssignOp = String -> Doc
text String
"="
  pretty CAssignOp
CMulAssOp = String -> Doc
text String
"*="
  pretty CAssignOp
CDivAssOp = String -> Doc
text String
"/="
  pretty CAssignOp
CRmdAssOp = String -> Doc
text String
"%="
  pretty CAssignOp
CAddAssOp = String -> Doc
text String
"+="
  pretty CAssignOp
CSubAssOp = String -> Doc
text String
"-="
  pretty CAssignOp
CShlAssOp = String -> Doc
text String
"<<="
  pretty CAssignOp
CShrAssOp = String -> Doc
text String
">>="
  pretty CAssignOp
CAndAssOp = String -> Doc
text String
"&="
  pretty CAssignOp
CXorAssOp = String -> Doc
text String
"^="
  pretty CAssignOp
COrAssOp  = String -> Doc
text String
"|="


instance Pretty CBinaryOp where
  pretty :: CBinaryOp -> Doc
pretty CBinaryOp
CMulOp = String -> Doc
text String
"*"
  pretty CBinaryOp
CDivOp = String -> Doc
text String
"/"
  pretty CBinaryOp
CRmdOp = String -> Doc
text String
"%"
  pretty CBinaryOp
CAddOp = String -> Doc
text String
"+"
  pretty CBinaryOp
CSubOp = String -> Doc
text String
"-"
  pretty CBinaryOp
CShlOp = String -> Doc
text String
"<<"
  pretty CBinaryOp
CShrOp = String -> Doc
text String
">>"
  pretty CBinaryOp
CLeOp  = String -> Doc
text String
"<"
  pretty CBinaryOp
CGrOp  = String -> Doc
text String
">"
  pretty CBinaryOp
CLeqOp = String -> Doc
text String
"<="
  pretty CBinaryOp
CGeqOp = String -> Doc
text String
">="
  pretty CBinaryOp
CEqOp  = String -> Doc
text String
"=="
  pretty CBinaryOp
CNeqOp = String -> Doc
text String
"!="
  pretty CBinaryOp
CAndOp = String -> Doc
text String
"&"
  pretty CBinaryOp
CXorOp = String -> Doc
text String
"^"
  pretty CBinaryOp
COrOp  = String -> Doc
text String
"|"
  pretty CBinaryOp
CLndOp = String -> Doc
text String
"&&"
  pretty CBinaryOp
CLorOp = String -> Doc
text String
"||"


instance Pretty CUnaryOp where
  pretty :: CUnaryOp -> Doc
pretty CUnaryOp
CPreIncOp  = String -> Doc
text String
"++"
  pretty CUnaryOp
CPreDecOp  = String -> Doc
text String
"--"
  pretty CUnaryOp
CPostIncOp = String -> Doc
text String
"++"
  pretty CUnaryOp
CPostDecOp = String -> Doc
text String
"--"
  pretty CUnaryOp
CAdrOp     = String -> Doc
text String
"&"
  pretty CUnaryOp
CIndOp     = String -> Doc
text String
"*"
  pretty CUnaryOp
CPlusOp    = String -> Doc
text String
"+"
  pretty CUnaryOp
CMinOp     = String -> Doc
text String
"-"
  pretty CUnaryOp
CCompOp    = String -> Doc
text String
"~"
  pretty CUnaryOp
CNegOp     = String -> Doc
text String
"!"


instance Pretty CConst where
  pretty :: CConst -> Doc
pretty (CIntConst Integer
i)    = String -> Doc
text (String -> Doc) -> (Integer -> String) -> Integer -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show (Integer -> Doc) -> Integer -> Doc
forall a b. (a -> b) -> a -> b
$ Integer
i
  pretty (CCharConst Char
c)   = String -> Doc
text (String -> Doc) -> (Char -> String) -> Char -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall a. Show a => a -> String
show (Char -> Doc) -> Char -> Doc
forall a b. (a -> b) -> a -> b
$ Char
c
  pretty (CFloatConst Float
f)  = Float -> Doc
float Float
f
  pretty (CStringConst String
s) = String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
s