{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE TypeSynonymInstances #-}



module Language.CPP.Pretty (

  codegen

) where 



import Text.PrettyPrint.HughesPJ

import Prelude hiding ((<>))

import Language.CPP.Syntax.AST



class Pretty t where

  pretty :: t -> Doc

  prettyPrec :: Int -> t -> Doc

  pretty = prettyPrec 0

  prettyPrec _ = pretty



class ToString t where

  toString :: t -> String



instance ToString CPPAssignOp where

  toString x = case x of

    CPPAssOp    -> "="

    CPPAssOpMul -> "*="

    CPPAssOpDiv -> "/="

    CPPAssOpRmd -> "%="

    CPPAssOpAdd -> "+="

    CPPAssOpSub -> "-="

    CPPAssOpShl -> "<<="

    CPPAssOpShr -> ">>="

    CPPAssOpAnd -> "&="

    CPPAssOpOr  ->  "|="

    CPPAssOpXor -> "^="



{-
  Priorities in C (http://www.difranco.net/cop2220/op-prec.htm)
 
  2:  comma
  4:  assignments
  6:  conditional
  8:  logical or
  10:  logical and
  12:  bitwise or
  14:  bitwise xor
  16:  bitwise and
  18:  equality/inequality test
  20: relational tests
  22: bitshift
  24: addition/subtraction
  26: multiplication/division/modulus
  28: preincrement/predecrement/negation/complement/cast/dereference/address/sizeof
  30: brackets/index/member/postincrement/postdecrement/
-}





instance Pretty CPPConst where

  pretty (CPPConstInt x) = text $ show x

  pretty (CPPConstChar x) = text $ "'" ++ x ++ "'"   -- TODO: character escaping

  pretty (CPPConstString x) = text $ "\"" ++ x ++ "\""

  pretty (CPPConstFloat x) = text x



prio :: Int -> Int -> Doc -> Doc

prio myL outerL doc = if myL<outerL then parens doc else doc



instance Pretty CPPExpr where

  prettyPrec l (CPPConst x) = prettyPrec l x

  prettyPrec l (CPPAssign o1 op o2) = prio 4 l $ (prettyPrec 5 o1) <+> (text $ toString op) <+> (prettyPrec 4 o2)

  prettyPrec l (CPPVar v) = text v

  prettyPrec l (CPPComma lst) = lparen <> (foldl (<>) empty $ punctuate comma $ map (prettyPrec 2) lst) <> rparen

  prettyPrec l (CPPBinary o1 CPPOpMul  o2) = prio 26 l $ (prettyPrec 26 o1) <> text "*"  <> (prettyPrec 27 o2)

  prettyPrec l (CPPBinary o1 CPPOpDiv  o2) = prio 26 l $ (prettyPrec 26 o1) <> text "/"  <> (prettyPrec 27 o2)

  prettyPrec l (CPPBinary o1 CPPOpRmd  o2) = prio 26 l $ (prettyPrec 26 o1) <> text "%"  <> (prettyPrec 27 o2)

  prettyPrec l (CPPBinary o1 CPPOpAdd  o2) = prio 24 l $ (prettyPrec 24 o1) <> text "+"  <> (prettyPrec 24 o2)

  prettyPrec l (CPPBinary o1 CPPOpSub  o2) = prio 24 l $ (prettyPrec 24 o1) <> text "-"  <> (prettyPrec 25 o2)

  prettyPrec l (CPPBinary o1 CPPOpShl  o2) = prio 22 l $ (prettyPrec 22 o1) <> text "<<" <> (prettyPrec 23 o2)

  prettyPrec l (CPPBinary o1 CPPOpShr  o2) = prio 22 l $ (prettyPrec 22 o1) <> text ">>" <> (prettyPrec 23 o2)

  prettyPrec l (CPPBinary o1 CPPOpLe   o2) = prio 20 l $ (prettyPrec 20 o1) <> text "<"  <> (prettyPrec 21 o2)

  prettyPrec l (CPPBinary o1 CPPOpGr   o2) = prio 20 l $ (prettyPrec 20 o1) <> text ">"  <> (prettyPrec 21 o2)

  prettyPrec l (CPPBinary o1 CPPOpGeq  o2) = prio 20 l $ (prettyPrec 20 o1) <> text ">=" <> (prettyPrec 21 o2)

  prettyPrec l (CPPBinary o1 CPPOpLeq  o2) = prio 20 l $ (prettyPrec 20 o1) <> text "<=" <> (prettyPrec 21 o2)

  prettyPrec l (CPPBinary o1 CPPOpEq   o2) = prio 18 l $ (prettyPrec 18 o1) <> text "==" <> (prettyPrec 19 o2)

  prettyPrec l (CPPBinary o1 CPPOpNeq  o2) = prio 18 l $ (prettyPrec 18 o1) <> text "!=" <> (prettyPrec 19 o2)

  prettyPrec l (CPPBinary o1 CPPOpAnd  o2) = prio 16 l $ (prettyPrec 16 o1) <> text "&"  <> (prettyPrec 16 o2)

  prettyPrec l (CPPBinary o1 CPPOpXor  o2) = prio 14 l $ (prettyPrec 14 o1) <> text "^"  <> (prettyPrec 14 o2)

  prettyPrec l (CPPBinary o1 CPPOpOr   o2) = prio 12 l $ (prettyPrec 12 o1) <> text "|"  <> (prettyPrec 12 o2)

  prettyPrec l (CPPBinary o1 CPPOpLAnd o2) = prio 10 l $ (prettyPrec 10 o1) <> text "&&" <> (prettyPrec 10 o2)

  prettyPrec l (CPPBinary o1 CPPOpLOr  o2) = prio  8 l $ (prettyPrec  8 o1) <> text "||" <> (prettyPrec 8  o2)

  prettyPrec l (CPPUnary  CPPOpPreInc o)   = prio 28 l $                       text "++" <> (prettyPrec 28 o )

  prettyPrec l (CPPUnary  CPPOpPreDec o)   = prio 28 l $                       text "--" <> (prettyPrec 28 o )

  prettyPrec l (CPPUnary  CPPOpPostInc o)  = prio 28 l $ (prettyPrec 28 o ) <> text "++"

  prettyPrec l (CPPUnary  CPPOpPostDec o)  = prio 28 l $ (prettyPrec 28 o ) <> text "--"

  prettyPrec l (CPPUnary  CPPOpAdr o)      = prio 28 l $                       text "&"  <> (prettyPrec 28 o )

  prettyPrec l (CPPUnary  CPPOpInd o)      = prio 28 l $                       text "*"  <> (prettyPrec 28 o )

  prettyPrec l (CPPUnary  CPPOpPlus o)     = prio 28 l $                       text "+"  <> (prettyPrec 28 o )

  prettyPrec l (CPPUnary  CPPOpMinus o)    = prio 28 l $                       text "-"  <> (prettyPrec 28 o )

  prettyPrec l (CPPUnary  CPPOpComp o)     = prio 28 l $                       text "~"  <> (prettyPrec 28 o )

  prettyPrec l (CPPUnary  CPPOpNeg o)      = prio 28 l $                       text "!"  <> (prettyPrec 28 o )

  prettyPrec l (CPPCond c (Just t) f)      = prio  6 l $ (prettyPrec 7  c ) <+> text "?"  <+> (prettyPrec 7  t ) <+> text ":" <+> (prettyPrec 6 f)

  prettyPrec l (CPPCond c Nothing t)       = prio  6 l $ (prettyPrec 7  c ) <> text "?:" <> (prettyPrec 6  t )

  prettyPrec l (CPPCast t e)               = prio 28 l $ lparen <> (pretty t) <> rparen <>  (prettyPrec 28 e )

  prettyPrec l (CPPSizeOfExpr e)           = prio 28 l $ text "sizeof" <> lparen <> (pretty e) <> rparen

  prettyPrec l (CPPSizeOfType t)           = prio 28 l $ text "sizeof" <> lparen <> (pretty t) <> rparen

  prettyPrec l (CPPIndex a b)              = prio 28 l $ (prettyPrec 28 a) <> lbrack <> (pretty b) <> rbrack

  prettyPrec l (CPPCall a b)               = prio 28 l $ (prettyPrec 28 a) <> lparen <> (hcat $ punctuate comma $ map pretty b) <> rparen

  prettyPrec l (CPPMember a m False)       = prio 28 l $ (prettyPrec 28 a) <> text "." <> text m

  prettyPrec l (CPPMember a m True)        = prio 28 l $ (prettyPrec 28 a) <> text "->" <> text m

  prettyPrec l (CPPNew a b)                = prio 28 l $ text "new" <+> (pretty a) <> lparen <> (hcat $ punctuate comma $ map pretty b) <> rparen



instance Pretty s => Pretty (Maybe s) where

  prettyPrec _ Nothing = empty

  prettyPrec l (Just x) = prettyPrec l x



instance (Pretty a, Pretty b) => Pretty (Either a b) where

  prettyPrec l (Left x) = prettyPrec l x

  prettyPrec l (Right x) = prettyPrec l x



instance Pretty CPPStat where

  pretty (CPPLabel s b) = (nest (-1000) $ (text s) <> char ':') $$ pretty b

  pretty (CPPCase x b) = (text "case" <+> pretty x <> char ':') $+$ (nest 2 (pretty b))

  pretty (CPPDefault b) = (text "default:") $+$ (nest 2 $ pretty b)

  pretty (CPPSimple x) = (pretty x) <> char ';'

  pretty (CPPCompound []) = empty

  pretty (CPPCompound [CPPStatement (c@(CPPCompound _))]) = pretty c

  pretty (CPPCompound [CPPStatement (c@(CPPVerbStat _))]) = pretty c

  pretty (CPPCompound [CPPStatement a]) = pretty a

  pretty (CPPCompound l) = lbrace $+$ (nest 2 $ vcat $ map pretty l) $+$ rbrace

  pretty (CPPIf c t (Just f)) = text "if" <+> parens (pretty c) <+> braces (pretty t) <+> text "else" <+> braces (pretty f)

  pretty (CPPIf c t Nothing) = text "if" <+> parens (pretty c) <+> braces (pretty t)

  pretty (CPPSwitch x b) = text "switch (" <> pretty x <> text ") {" <+> pretty b <+> text "}"

  pretty (CPPWhile x False b) = text "while" <> (parens $ pretty x) <+> (braces $ pretty b)

  pretty (CPPWhile x True b) = text "do" <+> (braces $ pretty b) <+> text "while" <> (parens $ pretty x) <> semi

  pretty (CPPFor f1 f2 f3 b) = text "for (" <> pretty f1 <> text ";" <+> pretty f2 <> text ";" <+> pretty f3 <> text ") {" $+$ nest 2 (pretty b) $+$ text "}"

  pretty (CPPGoto l) = text ("goto " ++ l ++ ";")

  pretty (CPPCont) = text "continue;"

  pretty (CPPBreak) = text "break;"

  pretty (CPPReturn x) = (text "return" <+> pretty x) <> text ";"

  pretty (CPPDelete x) = (text "delete" <+> pretty x) <> text ";"

  pretty (CPPVerbStat l) = lbrace $+$ (nest 2 $ vcat $ map text l) $+$ rbrace



instance Pretty CPPQual where

  pretty (CPPQualConst) = text "const"

  pretty (CPPQualVolatile) = text "volatile"



instance Pretty CPPStorSpec where

  pretty (CPPAuto) = text "auto"

  pretty (CPPRegister) = text "register"

  pretty (CPPStatic) = text "static"

  pretty (CPPExtern) = text "extern"

  pretty (CPPTypedef) = text "typedef"

  pretty (CPPInline) = text "inline"

  pretty (CPPVirtual) = text "virtual"



instance Pretty a => Pretty [a] where

  pretty [] = empty

  pretty [a] = pretty a

  pretty (a:b) = pretty a <+> pretty b



instance Pretty CPPVisibility where

  pretty CPPPublic = text "public"

  pretty CPPPrivate = text "private"

  pretty CPPProtected = text "protected"



instance Pretty (CPPType,Doc,Int,[CPPQual]) where

  pretty (CPPPtr qual typ,s,l,q) = pretty (typ,char '*' <> (pretty q <+> (prio 4 l s)),4::Int,qual)

  pretty (CPPRef qual typ,s,l,q) = pretty (typ,char '&' <> (pretty q <+> (prio 4 l s)),4::Int,qual)

  pretty (CPPArray qual typ len,s,l,_) = pretty (typ,((prio 2 l s) <> lbrack <> pretty len <> rbrack),2::Int,qual)

  pretty (CPPTypePrim prim,s,l,q) = pretty q <+> (text prim <+> s)

  pretty (CPPTempl prim lst,s,l,q) = pretty q <+> (text prim <> char '<' <> (hcat $ punctuate comma $ map pretty lst) <> char '>') <+> s



instance Pretty (CPPType,Doc) where

  pretty (typ,doc) = pretty (typ,doc,0 :: Int,[]::[CPPQual])



instance Pretty CPPType where

  pretty x = pretty (x,empty)



prettyString Nothing = empty

prettyString (Just x) = text x



instance Pretty CPPDecl where

  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Nothing }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual)

  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitValue code) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> char '=' <> pretty code

  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitCall  args) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> lparen <> (hcat $ punctuate comma $ map pretty args) <> rparen

  pretty (CPPDecl { cppDeclName=name, cppType = typ, cppTypeQual = qual, cppTypeStor = stor, cppDeclInit=Just (CPPInitArray args) }) = pretty stor <+> pretty (typ,prettyString name,0 :: Int,qual) <> char '=' <> lbrace <> (hcat $ punctuate comma $ map pretty args) <> rbrace



instance Pretty CPPDef where

  pretty (CPPDef { cppDefName=name, cppDefRetType=typ, cppDefStor=stor, cppDefArgs=args, cppDefBody = body, cppDefQual=qual }) =

    let pre = (pretty stor <+> pretty (typ, text name)) <> parens (hcat $ punctuate comma $ map pretty args) <+> (hsep $ map pretty qual)

        in case body of

          Nothing -> pre <> text ";"

          Just b -> pre <+> text "{" $+$ (nest 2 $ pretty b) $+$ text "}"



instance Pretty (CPPConstr,String) where

  pretty (CPPConstr { cppConstrStor=stor, cppConstrArgs=args, cppConstrBody=body, cppConstrInit=ini },name) =

    let pre = (pretty stor <+> text name) <> parens (hcat $ punctuate comma $ map pretty args)

        init [] = empty

        init lst = colon <+> (hcat $ punctuate (text ", ") $ map (\(tp,args) -> pretty tp <> (parens $ hcat $ punctuate comma $ map pretty args)) lst)

        in case body of

          Nothing -> (pre <+> init ini) <> text ";"

          Just b -> (pre <+> init ini) <+> text "{" $+$ (nest 2 $ pretty b) $+$ text "}"



instance Pretty CPPBlockItem where

  pretty (CPPStatement stat) = pretty stat

  pretty (CPPBlockDecl decl) = pretty decl <> text ";"

  pretty (CPPComment str) = text "//" <+> text str



instance Pretty CPPMacroStm where

  pretty (CPPMacroIncludeUser str) = text "#include" <+> (text $ "\"" ++ str ++"\"")

  pretty (CPPMacroIncludeSys str)  = text "#include" <+> (text $ "<" ++ str ++ ">")

  pretty (CPPMacroDefine { cppMacroDefName = name, cppMacroDefArgs = Nothing, cppMacroDefExpr = expr }) = text "#define" <+> text name <+> text expr

  pretty (CPPMacroDefine { cppMacroDefName = name, cppMacroDefArgs = Just lst, cppMacroDefExpr = expr }) = text $ "#define " ++ name ++ "(" ++ (foldr1 (\a b -> a++","++b) lst) ++ ")" ++ " " ++ expr



instance Pretty CPPElement where

  pretty (CPPElemNamespace (name,ns)) = (text "namespace" <+> text name <+> lbrace) $+$ nest 2 (pretty ns) $+$ rbrace

  pretty (CPPElemDecl decl) = pretty decl <> semi

  pretty (CPPElemDef def) = pretty def

  pretty (CPPElemClass cls) = pretty cls



instance Pretty CPPNamespace where

  pretty (CPPNamespace list) = vcat $ map (\x -> pretty x $+$ char ' ') list



instance Pretty CPPClass where

  pretty (CPPClass { cppClassName = name, cppClassInherit = inh, cppClassDecls = decls, cppClassDefs = defs, cppClassConstrs = constrs }) = 

    let sel vis lst = map snd $ filter (\x -> fst x == vis) lst

        inhh [] = empty

        inhh lst = colon <+> (hcat $ punctuate (text ", ") $ map (\(vis,tp) -> pretty vis <+> pretty tp) lst)

        decl vis = case sel vis decls of

          [] -> empty

          lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map (\x -> pretty x <> semi) lst) $+$ text " "

        def vis = case sel vis defs of

          [] -> empty

          lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map pretty lst) $+$ text " "

        constr vis = case sel vis constrs of

          [] -> empty

          lst -> (nest (-2) (pretty vis) <> char ':') $+$ vcat (map (\x -> pretty (x,name)) lst) $+$ text " "

        comb vis = constr vis $+$ def vis

        in (text "class" <+> text name <+> inhh inh <+> char '{') $+$ nest 2 (decl CPPPrivate $+$ decl CPPProtected $+$ decl CPPPublic $+$ comb CPPPrivate $+$ comb CPPProtected $+$ comb CPPPublic) $+$ char '}' <> semi



instance Pretty CPPFile where

  pretty (CPPFile { cppMacroStm = macro, cppUsing = using, cppTranslUnit = unit }) = vcat (map pretty macro) $+$ text " " $+$ vcat (map (\x -> text "using" <+> text "namespace" <+> text x <> semi) using) $+$ text " " $+$ pretty unit



codegen :: Pretty x => x -> String

codegen = render . pretty