module PpCore where

import CoreIDL
import Literal
import BasicTypes
import PP
import Opts  ( optDebug, optHaskellToC, optShortHeader,
	       optCompilingMsIDL
	     )
import List  ( partition )
import Utils ( mapMb, notNull )
import Attribute ( hasAttributeWithName )

import Maybe ( fromMaybe )
import Char  ( isAlphaNum, toUpper )

type CoreDoc = 
  PPDoc ( Bool   -- output debugging information?
        , Bool   -- output as C decls?
	, Bool   -- within a C comment?
	, Bool   -- expand library decls?
	, String -- type of the 'this' pointer.
		 -- "" => not processing an object interface.
	)

showCore :: CoreDoc -> String
showCore cd = showPPDoc cd (optDebug, False, False, True, "")

showHeader :: String -> CoreDoc -> String
showHeader fname cd = 
  showPPDoc (text "#ifndef" <+> text fname' $$
  	     text "#define" <+> text fname' $$
	     cd $$ text "#endif")
	    (False, True{-as C-}, False, True, "")
 where
  uu     = "__"
  fname' = uu ++ map canon fname ++ uu

  canon x
   | isAlphaNum x = toUpper x
   | otherwise    = '_'


ppCore :: [Decl] -> CoreDoc
ppCore ls = vsep (map ppDecl ls) $$ text ""

ppHeaderDecl :: [Id] -> Decl -> CoreDoc
ppHeaderDecl is d = vsep (map forwardDecl is) $$
		    ppDecl d $$
		    text ""
 where 
   forwardDecl i
     | is_object =
       let nm = idName i in
       text "#ifndef __" <> text nm <> text "_FWD_DEFINED__" $$
       text "#define __" <> text nm <> text "_FWD_DEFINED__" $$
       text "typedef struct" <+> text nm <+> text nm <> semi $$
       text "#endif"
     | otherwise = empty
    where
     attrs      = idAttributes i
     is_object  = 
	attrs `hasAttributeWithName` "object" ||
	attrs `hasAttributeWithName` "odl"
    

setDebug :: Bool -> CoreDoc -> CoreDoc
setDebug deb d = 
  getPPEnv $ \ (_,as_c,comment,flg,str) ->
  setPPEnv (deb,as_c,comment,flg,str) d

getCommentFlag :: (Bool -> CoreDoc) -> CoreDoc
getCommentFlag cont = getPPEnv $ \ (_,_,comment,_,_) -> cont comment

inComment :: CoreDoc -> CoreDoc
inComment d1 = 
  getPPEnv $ \ (deb,c,_,flg,str) ->
  setPPEnv (deb,c,True,flg,str) d1 

setLibFlag :: Bool -> CoreDoc -> CoreDoc
setLibFlag flg d =
  getPPEnv $ \ (deb,as_c,comment,_,str) ->
  setPPEnv (deb,as_c,comment,flg,str) d

ifTopLevLib :: CoreDoc -> CoreDoc -> CoreDoc
ifTopLevLib if_true if_false = 
  getPPEnv $ \ (_,_,_,flg,_) ->
  if flg then
    if_true
  else
    if_false


ifC :: CoreDoc -> CoreDoc -> CoreDoc
ifC onTrue onFalse = 
  getPPEnv $ \ (_,flg,_,_,_) ->
  if flg then
     onTrue
  else
     onFalse

setThisType :: String -> CoreDoc -> CoreDoc
setThisType this_ty d = 
  getPPEnv $ \ (deb,as_c,comment,flg,_) ->
  setPPEnv (deb,as_c,comment,flg,this_ty) d

getThisType :: (String -> CoreDoc) -> CoreDoc
getThisType cont =
  getPPEnv $ \ (_,_,_,_,this_ty) ->
  cont this_ty

whenNotC :: CoreDoc -> CoreDoc
whenNotC d = ifC empty d

commentOutIfC :: CoreDoc -> CoreDoc
commentOutIfC d = ifC (commentOut d) d

commentOut :: CoreDoc -> CoreDoc
commentOut d = 
   getCommentFlag $ \ flg ->
      start_comment flg <> inComment d <> end_comment flg
 where
  start_comment insideComment
   | insideComment = empty
   | otherwise     = text "/*"

  end_comment insideComment
   | insideComment = empty
   | otherwise     = text "*/"

getIfC :: (Bool -> CoreDoc) -> CoreDoc
getIfC cont = 
  getPPEnv $ \ (_,flg,_,_,_) ->
  cont flg

ifDebug :: CoreDoc -> CoreDoc -> CoreDoc
ifDebug onTrue onFalse =
  getPPEnv $ \ (flg,_,_,_,_) ->
  if flg then
     onTrue
  else
     onFalse

ppDecl :: Decl -> CoreDoc
ppDecl (Typedef i t orig_ty) =
  (if ignorable then commentOutIfC else id) $
  case orig_ty of
   FunTy cc res ps ->
        text "typedef" <+> ppType (resultType res) <+> 
	     parens ( ppCallConv True cc <+> char '*' <> ppId i id) <>
             ppTuple (map ppParam ps) <> semi
   _ ->
    ifC (ppId i (\ x -> text "typedef" <+> x <+> ppType orig_ty))
        (ppId i (\ x -> text "typedef" <+> x <+> ppType t)) <> semi
 where
  ignorable = idAttributes i `hasAttributeWithName` "ignore"

ppDecl (Constant i _ o_t e) =
 ifC (text "#define") (text "const") <+> ppId i (<> ifC empty (ppType o_t)) <+> ifC empty equals <+> ppExpr e <> ifC empty semi

ppDecl (Interface i is_ref inherit decls)
  | is_ref =
    ifC empty
	(ppId i ($+$ (text "interface")) <> semi)
  | otherwise  =
    ifC
      pprIface
      ((hang (ppIdVert i ($+$ (text "interface")) <+> pp_inherit <+> char '{')
	 3   (ppCoreDecls decls (map ppDecl decls))) $$
       char '}' <> semi)
 where
  attrs      = idAttributes i
  is_object  = 
	attrs `hasAttributeWithName` "object" ||
	attrs `hasAttributeWithName` "odl"

  pprIface
   | optShortHeader || pure_dispatch = commentOutIfC (text "interface" <+> text (idOrigName i) <+> text "{};")
   | not is_object = text "typedef struct" <+> text (idOrigName i) <+> char '*' <> text (idOrigName i) <> semi
   | otherwise     =
--      text "typedef struct" <+> text (idOrigName i) <+> text (idOrigName i) <> semi $$
      ppCoreDecls non_meth_decls (map ppDecl non_meth_decls) $$
       (hang (text "typedef struct" <+> text (idOrigName i ++ "Vtbl") <+> char '{')
         3   ((if optHaskellToC then id else setThisType (idOrigName i))
	        ( ppInhMethodFiller $$ 
		  ppCoreDecls meth_decls (map ppDecl the_meth_decls)))) $$
       char '}' <+> text (idName i ++ "Vtbl") <> semi $$ text "" $$
       hang (text "struct" <+> text (idName i) <+> char '{')
         2  (text "struct" <+> text (idName i ++ "Vtbl") <+> char '*' <> text "lpVtbl" <> semi $$
	     char '}' <> semi) $$
       if optHaskellToC then 
          empty 
       else
	  text "#ifdef COBJMACROS" $$
	  vcat (map (mkObjMacros (idName i)) decls) $$
	  text "#endif" <+> commentOut (text "COBJMACROS")

  the_meth_decls = map (removeAttrs) meth_decls

  removeAttrs m  = m{declId=(declId m){idAttributes=[]}}

  (meth_decls, non_meth_decls) = partition isMethod decls

  ppInhMethodFiller
    | is_idispatch || is_iunknown = empty
    | is_dispatch  = ppDecls (map (\ x -> text "void*" <+> text ("reserved"++show x)) [(0::Int)..6])
    | otherwise    = ppDecls (map (\ x -> text "void*" <+> text ("reserved"++show x)) [(0::Int)..2])

  is_dispatch = any (\ x -> qName (fst x) == "IDispatch") inherit

  (is_idispatch, is_iunknown) =
    case (idOrigName i) of
      "IDispatch" -> (True, False)
      "IUnknown"  -> (False, True)
      _		  -> (False, False)

  pure_dispatch = not is_idispatch && is_dispatch && not has_dual
    
  has_dual = (idAttributes i) `hasAttributeWithName` "dual"

  isMethod (Method _ _ _ _ _) = True
  isMethod _		      = False

  mkObjMacros if_nm (Method methId _ _ args _) = 
    hang (text "#define" <+> text (if_nm ++ '_':idOrigName methId) <> arg_list <+> char '\\')
      5  (text "(This)->lpVtbl->" <> text (idOrigName methId) <> arg_list)
   where
    arg_list = parens (hcat (punctuate comma (map text ("This" : map (idName.paramId) args))))
  mkObjMacros _ _ = empty

  pp_inherit
   | not optDebug && optCompilingMsIDL =
      case inherit of
	  []        -> empty
	  ((x,_):_) -> char ':' <+> text (qName x)
   | otherwise =
   case inherit of
     [] -> empty
     ls -> char ':' <+> hsep (punctuate comma (map (\ (x,y) -> ppQualName x <> 
							       commentOut (text (show y))) ls))

ppDecl (Module i decls) =
 ifC (ppCoreDecls decls (map ppDecl decls))
     (hang (ppIdVert i ($+$ (text "module")) <+> char '{')
        3   (ppCoreDecls decls (map ppDecl decls)) $$
      text "};")

ppDecl (DispInterface i (Just d) _ _) =
 ifC (commentOutIfC (text "dispinterface" <+> text (idName i) <+> text "{};"))
     (hang (ppIdVert i ($+$ (text "dispinterface")) <+> char '{')
        3  (ppId (declId d) (\ x -> x <+> text "interface") <> semi $$ ifDebug (ppDecl d) empty) $$
      whenNotC (text "};"))

ppDecl (DispInterface i _ props meths) =
 ifC (commentOutIfC (text "dispinterface" <+> text (idName i) <+> text "{};"))
     (hang (ppIdVert i ($+$ (text "dispinterface")) <+> char '{')
       3   (hang (text "properties:")
             2   (ppDecls (map ppDecl props)) $$
	    hang (text "methods:")
             2   (ppCoreDecls meths (map ppDecl meths))) $$
      text "};")

ppDecl (Library i [])
 | not optDebug  = text "importlib" <> parens (text (show (idName i))) <> semi
ppDecl (Library i decls) =
 ifC 
   (commentOutIfC (text "library" <+> text (idOrigName i)))
   (ppIdVert i ($+$ (text "library"))) $$
 ifTopLevLib 
   (commentOutIfC (char '{') $$
    setLibFlag False (ppFwdDecls $$
		      ppCoreDecls decls (map ppDecl decls)) $$
    commentOutIfC (text "};"))
   (commentOutIfC (text "{};"))
 where
  ifaces = filter isInterface decls

  ppFwdDecls = vsep (map ppFwdDecl ifaces)

  ppFwdDecl (Interface ifaceId _ inherit _) =
   ifC (if pure_dispatch then 
           empty 
	else 
	   text "typedef struct" <+> text (idOrigName ifaceId) <+> text (idOrigName ifaceId) <> semi)
       (text "interface" <+> text (idOrigName ifaceId) <> semi)
    where
     is_idispatch =
      case (idOrigName ifaceId) of
        "IDispatch" -> True
        _	    -> False

     pure_dispatch = not is_idispatch && is_dispatch && not has_dual
     is_dispatch = any (\ x -> qName (fst x) == "IDispatch") inherit
     has_dual = (idAttributes ifaceId) `hasAttributeWithName` "dual"

  ppFwdDecl _ = empty

  isInterface Interface{} = True
  isInterface _		  = False


ppDecl (CoClass i decls) =
 ifC (commentOutIfC (text "coclass" <+> text (idOrigName i) <+> text "{};"))
     (hang (ppIdVert i ($+$ (text "coclass")) <+> char '{')
       3   (ppDecls (map ppCoClassDecl decls)) $$
      commentOutIfC (text "};"))

ppDecl (Property i ty _ _ _) = ppId i ($$ (ppType ty)) <> semi

ppDecl (Method i cconv res args _) = 
  getThisType $ \ str ->
  (if (null str) then -- not an object method.
     ppId i ($$ (ifC (text "extern") empty <+> ppResult res <+> ppCallConv True cconv))
   else
     ppResult res <+> parens ( ppMethodId i (\ x -> ppCallConv True cconv <+> char '*' <> x)))
       <+>
  pp_param <> semi
 where
  ppMethodId mid cont = ifC (ppId i' cont) (ppId mid  cont)

  attrs = idAttributes i

  i'
   | attrs `hasAttributeWithName` "propget" = i{idOrigName="get"++idOrigName i}
   | attrs `hasAttributeWithName` "propput" = i{idOrigName="put"++idOrigName i}
   | attrs `hasAttributeWithName` "propputref" = i{idOrigName="put"++idOrigName i}
   | otherwise				       = i

  pp_param =
   getThisType $ \ str ->
   let
    ty = Pointer Ref False (Name str str Nothing Nothing Nothing Nothing)

    args' 
     | null str  = args
     | otherwise = (Param (Id "This" "This" Nothing []) 
			  In ty ty False):args
   in			  
   ppTupleVert (map ppParam args')

ppDecl (HsLiteral str) = whenNotC (text "haskell" <> parens (text str) <> semi)
ppDecl (CInclude  str) = text "include" <+> text str
ppDecl (CLiteral str) = 
  ifC (text str)
      (text "cpp_quote" <> parens (text str))

ppCoreDecls :: [Decl] -> [CoreDoc] -> CoreDoc
ppCoreDecls [] [] = empty
ppCoreDecls (CInclude _ : as) (b:bs) = b $$ ppCoreDecls as bs
ppCoreDecls (CLiteral _ : as) (b:bs) = b $$ ppCoreDecls as bs
ppCoreDecls (_:as) (b:bs)            = b $$ ppCoreDecls as bs
ppCoreDecls [] as = vcat as
ppCoreDecls _ []  = empty

ppCoClassDecl :: CoClassDecl -> CoreDoc
ppCoClassDecl (CoClassInterface i _)     = ppId i (<+> whenNotC (text "interface"))
ppCoClassDecl (CoClassDispInterface i _) = ppId i (<+> whenNotC (text "dispinterface"))

ppId :: Id -> (CoreDoc -> CoreDoc) -> CoreDoc
ppId i ty
  | notNull attrs = (ty (commentOutIfC (ppList (map ppAttr attrs)))) <+> ppModule i
  | otherwise     = ty empty <+> ppModule i
  where
    attrs  = idAttributes i

--
-- [ a1
-- , a2
--   ..
-- ]
-- foo

ppIdVert :: Id -> (CoreDoc -> CoreDoc) -> CoreDoc
ppIdVert i ty		  
  | notNull attrs' = (ty (commentOutIfC (ppListVert (map ppAttr attrs')))) <+> ppModule i
  | otherwise      = ty empty <+> ppModule i
  where
    attrs  = idAttributes i
    attrs' = filter notIsAny attrs
    
    notIsAny (Attribute "any" _) = False
    notIsAny _			 = True

-- print the name of an Id, and possibly what 
-- file/module it is coming from.
ppModule :: Id -> CoreDoc
ppModule i =
   ifDebug 
      (text $
       case mb_mod of
         Nothing  -> nm
         Just m   -> m++'.':nm)
      (text (idOrigName i))
   where
    mb_mod = idModule i
    nm     = idName i

ppAttr :: Attribute -> CoreDoc
ppAttr (AttrMode dir)        = ppDirection dir
ppAttr (Attribute nm [])     = text nm
ppAttr (Attribute nm ps)     = text nm <> ppTuple (map ppAttrParam ps)
ppAttr (AttrDependent r ps)  = ppDepReason r <> ppTuple (map ppAttrParam ps)

ppAttrParam :: AttributeParam -> CoreDoc
ppAttrParam (ParamLit  l) = ppLit l
ppAttrParam (ParamType t) = ppType t
ppAttrParam (ParamExpr e) = ppExpr e
ppAttrParam (ParamVar n)  = text n
ppAttrParam ParamVoid     = empty
ppAttrParam (ParamPtr a)  = char '*' <> ppAttrParam a

ppDepReason :: DepReason -> CoreDoc
ppDepReason r = 
  text $
  case r of
    SizeIs   -> "size_is"
    LengthIs -> "length_is"
    LastIs   -> "last_is"
    FirstIs  -> "first_is"
    MaxIs    -> "max_is"
    MinIs    -> "min_is"
    SwitchIs -> "switch_is"

ppType :: Type -> CoreDoc
ppType (Integer Natural True)   = text "int"
ppType (Integer LongLong True)  = text "int64" 
ppType (Integer LongLong False) = text "uint64" 
ppType (Integer sz signed) = (if signed then empty else text "unsigned") <+> ppSize sz
ppType StablePtr =
  ifC (text "unsigned long")
      (text "stablePtr")

 -- (res (*)(args))
ppType (FunTy cc res params) = ppFunTy cc res params

ppType (Float sz) =
 case sz of
   Short    -> text "float"
   Long     -> text "double"
   LongLong -> text "long double"
   Natural  -> text "float"	       

ppType (Char signed)
 | signed    = text "signed char"
 | otherwise = text "char"

ppType WChar  = text "wchar_t"
ppType Bool   = text "boolean"
ppType Octet  = text "char"
ppType Any    = text "any"
ppType Object = text "Object"
ppType (String _ isUnique mb_expr) =
  ifC (text "char*")
      ((if isUnique then text "[unique]" else empty) <> text "string" <> pp_expr)
 where
  pp_expr =
   fromMaybe empty
             (mapMb (\ e -> char '<' <> ppExpr e <> char '>') mb_expr)

ppType (WString isUnique mb_expr) =
 ifC (text "WCHAR*")
     ((if isUnique then text "[unique]" else empty) <> text "wstring" <> pp_expr)
 where
  pp_expr =
   fromMaybe empty
             (mapMb (\ e -> char '<' <> ppExpr e <> char '>') mb_expr)

ppType (Sequence t mb_expr _) =
  text "sequence" <> char '<' <>
  ppType t <> pp_expr
  where
  pp_expr =
   fromMaybe (char '>')
             (mapMb (\ e -> comma <> ppExpr e <> char '>') mb_expr)

ppType (Fixed e i) =
  text "fixed" <> char '<' <>
  ppExpr e <> comma <> ppILit i <> char '>'

--ppType (Name nm onm mod attrs (Just ty) _) = ppModule (Id nm nm mod (fromMaybe [] attrs)) <> parens (ppType ty)

ppType (Name nm onm md attrs _ _) = ppModule (Id nm onm md (fromMaybe [] attrs))
ppType (Struct i [] _) = text "struct" <+> ppId i id
ppType (Struct i fields _) = 
 hang (ppId i (<> text "struct") <+> char '{')
   3  (ppDecls (map ppField fields)) $$
 char '}'

ppType (Enum i _ vals) = 
 (hang (ppId i (<> text "enum") <+> char '{')
   3   (vsep (punctuate comma (map ppEnumValue vals)))) $$
 char '}'

ppType (Union nm switch_ty switch_nm union_nm switches) = 
 hang (ppId nm (<> text "union") <+> commentOutIfC (text "switch" <>
       parens (ppId switch_nm (<> (ppType switch_ty))) <+> ppId union_nm id) <+> char '{')
   3  (ppDecls (map (ppSwitch True) switches)) $$
 char '}'

ppType (UnionNon tag switches) = 
 hang (ppId tag (<> text "union") <+> char '{')
   3  (ppDecls (map (ppSwitch False) switches)) $$
 char '}'

ppType (CUnion i fields _) = 
 hang (ppId i (<> text "union") <+> char '{')
   3  (ppDecls (map ppField fields)) $$
 char '}'

ppType (Pointer pt _ ty)   = ppType ty <> ppPointerType pt <> char '*'
ppType (Array t dims)      = ppArray empty  t dims
ppType Void                = text "void"
ppType (Iface nm md onm _ _ _) = ppModule (Id nm onm md [])

ppType (SafeArray t)      = text "SAFEARRAY" <> ifC (char '*') (parens (ppType t))
				    -- In .h mode, we run the risk of nested comments here
				    -- should we have a SAFEARRAY of a SAFEARRAY (yes, it does
				    -- happen!).

ppEnumValue :: EnumValue -> CoreDoc
ppEnumValue (EnumValue vi (Left val)) = ppId vi id <+> equals <+> text (show val)
ppEnumValue (EnumValue vi (Right e))  = ppId vi id <+> equals <+> ppExpr e


ppArray :: CoreDoc -> Type -> [Expr] -> CoreDoc
ppArray d t dims = ppType t <+> d <> ppArrayDims dims

ppPointerType :: PointerType -> CoreDoc
ppPointerType pt =
  ifDebug (char '{' <> p <> char '}') empty
 where
  p =
   char $
   case pt of
     Ref    -> 'r'
     Ptr    -> 'p'
     Unique -> 'u'

ppFunTy :: CallConv -> Result -> [Param] -> CoreDoc
ppFunTy cc res params = 
  parens (ppResult res <+> 
          parens (ppCallConv True cc <+> char '*') <>
	  ppTuple (map ppParam params))

ppArrayDims :: [Expr] -> CoreDoc
ppArrayDims []    = ifC (text "[1]") (text "[]")
ppArrayDims [e]   = char '[' <> ppExpr e <> char ']'
ppArrayDims [l,h] = char '[' <> ppExpr l <+> text ".." <+> ppExpr h <> char ']'
ppArrayDims _     = error "PpCore.ppArrayDims: don't know how to handle an interval with more than elts"

ppExpr :: Expr -> CoreDoc
ppExpr e =
 case e of
  Binary bop e1 e2 -> ppExpr e1 <+> ppBinaryOp bop <+> ppExpr e2
  Cond e1 e2 e3    -> ppExpr e1 <+> char '?' <+> ppExpr e2 <+> char ':' <+> ppExpr e3
  Unary op e1      -> parens (ppUnaryOp op <+> ppExpr e1)
  Var nm           -> text nm
  Lit l            -> ppLit l
  Cast t e1        -> parens (ppType t) <> parens (ppExpr e1)
  Sizeof t         -> text "sizeof" <> parens (ppType t)

ppParam :: Param -> CoreDoc
ppParam (Param i _ (Array t e) _ _) = ppArray (ppId i id) t e
ppParam (Param i _ t orig_ty _) = 
   ppId i (<> (ppType t <> ppOrig))
 where 
  ppOrig = ifDebug (parens (ppType orig_ty)) empty

ppSwitch :: Bool -> Switch -> CoreDoc
ppSwitch inEncUn (SwitchEmpty Nothing) 
  | inEncUn   = commentOutIfC (text "default: ")
  | otherwise = commentOutIfC (text "[default] ")
ppSwitch inEncUn (SwitchEmpty (Just ls)) = commentOutIfC (ppCaseLabels inEncUn (map fst ls))
ppSwitch inEncUn (Switch i labs t orig_ty) =
 hang (commentOutIfC $ ppCaseLabels inEncUn labs)
  3   (ppId i (<> (ppType t <> ppOrig)))
 where 
  ppOrig = ifDebug (parens (ppType orig_ty)) empty

ppField :: Field -> CoreDoc
ppField (Field i (Array t es) _ _ _) = ppArray (ppId i id) t es
ppField (Field i t orig_ty mb_sz _) = 
   ppId i (<> (ppType t <> ppOrig)) <> pp_bit_field
 where 
  pp_bit_field = 
    case mb_sz of
      Nothing -> empty
      Just x  -> char ':' <+> text (show x)

  ppOrig = ifDebug (parens (ppType orig_ty)) empty

ppResult :: Result -> CoreDoc
ppResult (Result red_ty orig_ty) =
  ifDebug (ppType red_ty <> parens (ppType orig_ty))
	  (ppType orig_ty)

ppCaseLabels :: Bool -> [CaseLabel] -> CoreDoc
ppCaseLabels inEncUn ls 
 | inEncUn    = hsep (punctuate (text ": ") (map ppCaseLabel ls))
 | otherwise  = brackets (hsep (punctuate comma (map ppCaseLabel ls)))

ppCaseLabel :: CaseLabel -> CoreDoc
ppCaseLabel Default  = text "default"
ppCaseLabel (Case e) = text "case" <+> ppExpr e