HsDeclPretty.hs

module HsDeclPretty (ppContext,ppFunDeps) where

import HsDeclStruct
import HsIdentPretty()
import HsAssocPretty()
import PrettySymbols(el,rarrow)
import PrettyPrint
import PrettyUtil(ppWhere,ppContext)
import HsGuardsPretty(ppRhs)


instance (PrintableOp i,Printable e, Printable p, Printable ds,
	  Printable t, Printable c, Printable tp) =>
         Printable (DI i e p ds t c tp) where
    ppi (HsTypeDecl _ tp t)                  =
        sep [kw "type" <+> tp <+> equals, dataNest t ]
    ppi (HsNewTypeDecl _ c tp t ders)        =
        sep [kw "newtype" <+> (ppContext $ ppis c) <+> tp <+> equals,
	       dataNest $ sep [ppi t, ppDeriving ders] ]
    ppi (HsDataDecl _ c tp summands ders)    =
        sep [kw "data" <+> (ppContext $ ppis c) <+> tp,
               dataNest $ 
	         sep [sep (zipWith (<+>) (equals : repeat (kw "|")) summands),
                      ppDeriving ders]]
    ppi (HsClassDecl _ c tp fundeps ds)               =
        sep [kw "class" <+> sep [ppContext $ ppis c, ppi tp, ppFunDeps fundeps],
             nest 2 $ ppWhere (ppis ds)]
    ppi (HsInstDecl _ optn c tp ds)                =
        sep [kw "instance" <+> sep [ppContext $ ppis c, ppi tp],
	     nest 2 $ ppWhere (ppis ds)]
    ppi (HsDefaultDecl _ t)                   =	kw "default" <+> ppiFTuple t
    ppi (HsTypeSig _ ns c t)                  =
	-- If they are printed vertically, every name except the first one
	-- must be indented...
        sep [hcat (punctuate comma (map wrap ns)),
	     letNest $  el <+> ppContext (ppis c) <+> t]
    ppi (HsFunBind _ ms)                      =  vcat ms
    ppi (HsPatBind _ p rhs ds)                =
        sep [wrap p, nest 2 $ sep [ppRhs equals rhs, ppWhere (ppis ds)]]
    ppi (HsInfixDecl _ fixity ops) =
	fixity <+> (fsep $ punctuate comma $ map ppiOp ops)

    ppi (HsPrimitiveTypeDecl _ ctx tp)       =
        kw "data" <+> ppContext (ppis ctx) <+> tp
    ppi (HsPrimitiveBind _ nm tp)            =
        kw "foreign" <+> kw "import" <+> wrap nm <+> el <+> tp

    wrap = ppi


instance (Printable i,Printable e, Printable p, Printable ds) =>
         Printable (HsMatchI i e p ds) where
    ppi (HsMatch _ f ps rhs ds) 
	= sep [wrap f <+> fsep (map wrap ps),
	       nest 2 $ sep [ppRhs equals rhs, ppWhere (ppis ds)]]

    wrap = ppi


instance (PrintableOp i,Printable t,Printable c)
      => Printable (HsConDeclI i t c) where
    ppi (HsConDecl _ is c n [t1,t2]) | isOp n = ppiBinOp t1 (con (ppiOp n)) t2
    ppi (HsConDecl _ is c n ts) = con (wrap n) <+> (fsep $ map wrap ts)
    ppi (HsRecDecl _ is c n fs)
	= con (wrap n) <+> (braces $ ppiFSeq $ map ppField fs)
	  where ppField (ns, t) = wrapFSeq ns <+> el <+> t

    wrap = ppi


instance Printable t => Printable (HsBangType t) where
    ppi (HsBangedType t)   = kw '!' <> wrap t
    ppi (HsUnBangedType t) = ppi t

    wrap (HsBangedType t)   = kw '!' <> wrap t
    wrap (HsUnBangedType t) = wrap t


-- Pretty prints deriving clauses
--ppDeriving :: [HsName] -> Doc
ppDeriving []  = empty
ppDeriving [i] = kw "deriving" <+> tcon i
ppDeriving is  = kw "deriving" <+> ppiFTuple (map tcon is)

ppFunDeps [] = empty
ppFunDeps fs = kw '|' <+> ppiFSeq (map ppFunDep fs)

ppFunDep (ts1,ts2) = fsep ts1<>rarrow<>fsep ts2