------------------------------------------------------------------
-- |
-- Module      :  Language.WebIDL.PrettyPrint
-- Copyright   :  (c) Dmitry Golubovsky, 2009
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-- 
--
--
-- Pretty printer for the IDL parsed syntax.
------------------------------------------------------------------

module Language.WebIDL.PrettyPrint (prettyPrint) where

import Data.Maybe
import Text.PrettyPrint.HughesPJ
import Language.WebIDL.Syntax

-- |Pretty print a parsed IDL specification.

prettyPrint :: IDLSpecification -> String

prettyPrint = render . prSpec

prSpec s = vcat (map prDef s)

prDef (IDLDefinition pos jd def) = vcat [prJd jd, prDef' def] <> semi

prJd (JavaDoc "") = empty
prJd (JavaDoc tx) = text tx


prDef' (IDLDefModule mn xattr defs) =
  prXattr xattr <+> text "module" <+> text mn <+> lbrace $+$ 
    (nest 2 $ prSpec defs) $+$ rbrace
prDef' (IDLDefInterface ii _ _ Nothing) =
  text "interface" <+> text ii
prDef' (IDLDefInterface ii xattr inhr (Just ib)) =
  prXattr xattr <+> text "interface" <+> text ii <+> prInhr inhr <+> lbrace $+$
    (nest 2 $ prIbody ib) $+$ rbrace
prDef' (IDLDefType td) = prTypeDcl td
prDef' (IDLDefExcept ex) = prExcept ex
prDef' (IDLDefConst cn) = prConst cn
prDef' (IDLDefValue iv Nothing) = text "valuetype" <+> text iv
prDef' (IDLDefValue iv (Just ts)) = text "valuetype" <+> text iv <+> prTypeSpec ts
prDef'  IDLDefPP = empty

prInhr [] = empty
prInhr sns = colon <+> hsep (punctuate comma (map prScoped sns))

prScoped (IDLScopedName ns) = hsep $ punctuate (space <> colon <> colon) (map text ns)

prIbody (IDLInterfaceBody exps) = vcat (map prExport exps)

prXattr [] = empty

prXattr as = brackets $ hsep $ punctuate comma (map prXattr' as)

prXattr' (IDLExtAttr jd ai mbds) = prJd jd $$ (text ai <> prMbds mbds)

prMbds Nothing = empty
prMbds (Just (IDLDetailSN sn)) = space <> equals <+> prScoped sn
prMbds (Just (IDLDetailID di pdcls)) = space <> equals <+> text di <> prParamDcls pdcls
prMbds (Just (IDLDetailPD pdcls)) = prParamDcls pdcls

prExport (IDLExport pos jd exp) = vcat [prJd jd, prExport' exp] <> semi

prExport' (IDLExpType td) = prTypeDcl td
prExport' (IDLExpExcept ex) = prExcept ex
prExport' (IDLExpConst cn) = prConst cn
prExport' (IDLExpAttr at) = prAttr at
prExport' (IDLExpOp op) = prOp op
prExport'  IDLExpPP = empty

prOp (IDLOpDcl xattr mbow pts oi pdcls sns) =
  prXattr xattr <+> prOpAttr mbow <+> prParamTypeSpec pts <+> text oi <>
          prParamDcls pdcls <+> prExcList "raises" sns

prOpAttr Nothing = empty
prOpAttr (Just IDLOneWay) = text "oneway"

prParamDcls [] = parens empty
prParamDcls pdcls = parens (hsep (punctuate comma (map prParam pdcls)))

prParam (IDLParamDcl xattr pattr pts pi) =
  prXattr xattr <+> prPattr pattr <+> prParamTypeSpec pts <+> text pi

prPattr IDLParamIn = text "in"
prPattr IDLParamOut = text "out"
prPattr IDLParamInOut = text "inout"

prAttr (IDLAttrDcl xattr ro pts ai getx setx) =
  prXattr xattr <+> (if ro then text "readonly" else empty) <+> text "attribute" <+>
          prParamTypeSpec pts <+> text ai <+> 
          prExcList "getraises" getx <+> prExcList "setraises" setx

prParamTypeSpec (IDLParamBaseSpec sb) = prBaseTypeSpec sb
prParamTypeSpec (IDLParamStringSpec st) = prStringType st
prParamTypeSpec (IDLParamScopedSpec sn) = prScoped sn
prParamTypeSpec  IDLParamVoid = text "void"

prExcList kw [] = empty
prExcList kw excs = text kw <+> parens (hsep (punctuate comma (map prScoped excs)))

prConst (IDLConstDcl ct ci ex) = 
  text "const" <+> prConstType ct <+> text ci <+> equals <+> prExpr ex

prConstType (IDLConstTypeFloat fl) = prFloatType fl
prConstType (IDLConstTypeInt it) = prIntType it
prConstType (IDLConstTypeString st) = prStringType st
prConstType  IDLConstTypeChar = text "char"
prConstType  IDLConstTypeBool = text "boolean"
prConstType  IDLConstTypeFixed = text "fixed"
prConstType  IDLConstTypeOctet = text "octet"
prConstType (IDLConstTypeScoped sn) = prScoped sn

prBaseTypeSpec (IDLBaseTypeFloat fl) = prFloatType fl
prBaseTypeSpec (IDLBaseTypeInt it) = prIntType it
prBaseTypeSpec  IDLBaseTypeChar = text "char"
prBaseTypeSpec  IDLBaseTypeBool = text "boolean"
prBaseTypeSpec  IDLBaseTypeOctet = text "octet"
prBaseTypeSpec  IDLBaseTypeAny = text "any"

prFloatType IDLFloat = text "float"
prFloatType IDLDouble = text "double"
prFloatType IDLLongDouble = text "long double"

prIntType (IDLSigned ii) = prIntType' ii
prIntType (IDLUnsigned ii) = text "unsigned" <+> prIntType' ii

prIntType' IDLShortInt = text "short"
prIntType' IDLLongInt = text "long"
prIntType' IDLLongLongInt = text "long long"

prStringType (IDLStringType Nothing) = text "string"
prStringType (IDLStringType (Just ex)) = text "string <" <> prExpr ex <> text ">"

prTypeDcl (IDLNative s) = text "native" <+> text s
prTypeDcl (IDLConstrFwd s) = text "struct" <+> text s
prTypeDcl (IDLTypeDef its ds) = text "typedef" <+> prTypeSpec its <+> prDecls ds
prTypeDcl (IDLStruct st) = prStruct st

prStruct (IDLStructType si mbs) = prMembers "struct" si mbs

prExcept (IDLExceptDcl ei mbs) = prMembers "exception" ei mbs

prMembers kw ii mbs = text kw <+> text ii <+> lbrace $+$ nest 2 (vcat (map prMember mbs)) $+$ rbrace

prMember (IDLMember its ds) = prTypeSpec its <+> prDecls ds <> semi

prTypeSpec (IDLSimpleSpec sts) = prSimpleTypeSpec sts
prTypeSpec (IDLStructSpec str) = prStruct str

prSimpleTypeSpec (IDLSimpleBase sb) = prBaseTypeSpec sb
prSimpleTypeSpec (IDLSimpleTmpl st) = prTmplTypeSpec st
prSimpleTypeSpec (IDLSimpleScoped sn) = prScoped sn

prTmplTypeSpec (IDLTmplSequence sq) = prSequence sq
prTmplTypeSpec (IDLTmplString st) = prStringType st
prTmplTypeSpec (IDLTmplFixed fx) = prFixedType fx

prSequence (IDLSequenceType ts Nothing) = text "sequence <" <> prSimpleTypeSpec ts <> text ">"
prSequence (IDLSequenceType ts (Just ex)) = 
  text "sequence <" <> prSimpleTypeSpec ts <> comma <+> prExpr ex <> text ">"

prFixedType (IDLFixedType ex1 ex2) = 
  text "fixed <" <> prExpr ex1 <> comma <+> prExpr ex2 <> text ">"

prDecl (IDLSimpleDecl s) = text s
prDecl (IDLComplexDecl iad) = prArray iad

prArray (IDLArrayDeclarator ai dims) = text ai <+> prDims dims

prDims [] = empty
prDims (d:ds) = lbrack <> prExpr d <> rbrack <> prDims ds

prDecls ds = hsep (punctuate comma (map prDecl ds))

prExpr (IDLParenExp ex) = parens (prExpr ex)
prExpr (IDLPrimScoped sn) = prScoped sn
prExpr (IDLPrimLit lit) = prLit lit
prExpr (IDLBinExp op l r) = prExpr l <+> prBin op <+> prExpr r
prExpr (IDLUnaryExp op e) = prUn op <> prExpr e

prBin IDLOr = text "|"
prBin IDLXor = text "^"
prBin IDLAnd = text "&"
prBin IDLShiftL = text "<<"
prBin IDLShiftR = text ">>"
prBin IDLAdd = text "+"
prBin IDLSub = text "-"
prBin IDLMult = text "*"
prBin IDLDiv = text "/"
prBin IDLRem = text "%"

prUn IDLPos = empty
prUn IDLNeg = text "-"
prUn IDLNot = text "~"

prLit (IDLIntLit s) = text s
prLit (IDLStringLit s) = text s
prLit (IDLCharLit s) = text s
prLit (IDLFixedLit s) = text s
prLit (IDLFloatLit s) = text s
prLit (IDLBoolLit s) = text s