-----------------------------------------------------------------------------
--
-- (c) The GHC Team, Noel Winstanley 1997-2000
--
-- Pretty printer for Haskell.
--
-----------------------------------------------------------------------------

> module HsPretty (PPLayout(..),PPHsMode(..),defaultMode,
> 		render, renderWithMode,
> 		ppHsModule,ppHsModuleHeader,
> 		ppHsDecl,
> 		ppHsQualType, ppHsType,
> 		ppHsExp,
> 		ppHsQName) where
> 
> import HsSyn
> 
> import qualified Pretty as P
> 
> infixl 5 $$$ 

Pretty printing monad.

> data PPLayout = PPOffsideRule		-- classical layout
> 	      | PPSemiColon		-- classical layout made explicit
> 	      | PPInLine		-- inline decls, \n between them 
> 	      | PPNoLayout		-- everything on a single line
> 	      deriving Eq
> 
> type Indent = Int
> 
> data PPHsMode = PPHsMode { 
> 			 classIndent,  -- class, instance
> 			 doIndent,
> 			 caseIndent,
> 			 letIndent,
> 			 whereIndent :: Indent,
> 			 onsideIndent :: Indent,
> 			 spacing :: Bool, -- blank lines between statements?
> 			 layout :: PPLayout,   -- to do
> 			 comments :: Bool -- to come later
> 			 }
> 
> defaultMode = PPHsMode{
> 		      classIndent = 8,
> 		      doIndent = 3,
> 		      caseIndent = 4,
> 		      letIndent = 4,
> 		      whereIndent = 6,
> 		      onsideIndent = 2,
> 		      spacing = True,
> 		      layout = PPOffsideRule, 
> 		      comments = True
> 		      }
> 
> newtype DocM s a = DocM (s -> a)
> 
> instance Functor (DocM s) where
> 	 fmap f xs = do x <- xs; return (f x)
> 
> instance Monad (DocM s) where
> 	(>>=) = thenDocM
> 	(>>) = then_DocM
> 	return = retDocM
> 
> {-# INLINE thenDocM #-}
> {-# INLINE then_DocM #-}
> {-# INLINE retDocM #-}
> {-# INLINE unDocM #-}
> {-# INLINE getPPEnv #-}
> thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s)
> then_DocM m k = DocM $ (\s ->case unDocM m $ s of a ->  unDocM k $ s)
> retDocM a = DocM (\s -> a)	
> unDocM :: DocM s a -> (s -> a)
> unDocM (DocM f) = f

All this extra stuff, just for this one function ...

> getPPEnv :: DocM s s 
> getPPEnv = DocM id

So that pp code still looks the same this means we lose some
generality though.

> type Doc = DocM PPHsMode P.Doc

The pretty printing combinators.

> empty :: Doc
> empty = return P.empty
> 
> nest :: Int -> Doc -> Doc
> nest i m = m >>= return . P.nest i 

 Literals.

> text, ptext :: String -> Doc
> text = return . P.text
> ptext = return . P.text
> 
> char :: Char -> Doc
> char = return . P.char
> 
> int :: Int -> Doc
> int = return . P.int
> 
> integer :: Integer -> Doc
> integer = return . P.integer
> 
> float :: Float -> Doc
> float = return . P.float
> 
> double :: Double -> Doc
> double = return . P.double
> 
> rational :: Rational -> Doc
> rational = return . P.rational

Simple Combining Forms

> parens, brackets, braces,quotes,doubleQuotes :: Doc -> Doc
> parens d = d >>= return . P.parens
> brackets d = d >>= return . P.brackets
> braces d = d >>= return . P.braces
> quotes d = d >>= return . P.quotes
> doubleQuotes d = d >>= return . P.doubleQuotes

Constants

> semi,comma,colon,space,equals :: Doc
> semi = return P.semi
> comma = return P.comma
> colon = return P.colon
> space = return P.space
> equals = return P.equals
> 
> lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc
> lparen = return  P.lparen
> rparen = return  P.rparen
> lbrack = return  P.lbrack
> rbrack = return  P.rbrack
> lbrace = return  P.lbrace
> rbrace = return  P.rbrace

Combinators

> (<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc
> aM <> bM = do{a<-aM;b<-bM;return (a P.<> b)}
> aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)}
> aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)}
> aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)}
> 
> hcat,hsep,vcat,sep,cat,fsep,fcat :: [Doc] -> Doc
> hcat dl = sequence dl >>= return . P.hcat
> hsep dl = sequence dl >>= return . P.hsep
> vcat dl = sequence dl >>= return . P.vcat
> sep dl = sequence dl >>= return . P.sep
> cat dl = sequence dl >>= return . P.cat
> fsep dl = sequence dl >>= return . P.fsep
> fcat dl = sequence dl >>= return . P.fcat

Some More

> hang :: Doc -> Int -> Doc -> Doc
> hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r}
> 
> -- Yuk, had to cut-n-paste this one from Pretty.hs
> punctuate :: Doc -> [Doc] -> [Doc]
> punctuate p []     = []
> punctuate p (d:ds) = go d ds
>                    where
>                      go d [] = [d]
>                      go d (e:es) = (d <> p) : go e es

This is the equivalent of runM now.

> renderWithMode :: PPHsMode -> Doc -> String
> renderWithMode ppMode d = P.render . unDocM d $ ppMode
> 
> render :: Doc -> String
> render = renderWithMode defaultMode
> 
> fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float -> 
> 		      (P.TextDetails -> a -> a) -> a -> Doc -> a
> fullRenderWithMode ppMode m i f fn e mD = 
> 		   P.fullRender m i f fn e $ (unDocM mD) ppMode
> 
> 
> fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) 
> 	      -> a -> Doc -> a
> fullRender = fullRenderWithMode defaultMode
> 
> -------------------------  Pretty-Print a Module --------------------
> ppHsModule :: HsModule -> Doc
> ppHsModule (HsModule mod mbExports imp decls) = 
>    topLevel (ppHsModuleHeader mod mbExports)
>             (map ppHsImportDecl imp ++ map ppHsDecl decls)
> 
> --------------------------  Module Header ------------------------------
> ppHsModuleHeader :: Module -> Maybe [HsExportSpec] ->  Doc
> ppHsModuleHeader (Module modName) mbExportList = mySep [
> 		 text "module",
> 		 text modName,
> 		 maybePP (parenList . map ppHsExportSpec) mbExportList,
> 		 text "where"]
> 
> ppHsExportSpec :: HsExportSpec -> Doc
> ppHsExportSpec (HsEVar name)                     = ppHsQNameParen name
> ppHsExportSpec (HsEAbs name)                     = ppHsQName name 
> ppHsExportSpec (HsEThingAll name)                = ppHsQName name <> text"(..)"
> ppHsExportSpec (HsEThingWith name nameList)      = ppHsQName name <>
>                                                    (parenList . map ppHsQNameParen $ nameList)
> ppHsExportSpec (HsEModuleContents (Module name)) = text "module" <+> text name 
> 
> ppHsImportDecl (HsImportDecl pos (Module mod) bool mbName mbSpecs) = 
> 	   mySep [text "import", 
> 		 if bool then text "qualified" else empty,
> 		 text mod, 
> 		 maybePP (\(Module n) -> text "as" <+> text n) mbName,
> 		 maybePP exports mbSpecs]
>            where
> 	   exports (b,specList) 
> 	    | b = text "hiding" <+> (parenList . map ppHsImportSpec $ specList)
> 	    | otherwise = parenList . map ppHsImportSpec $  specList
> 
> ppHsImportSpec :: HsImportSpec -> Doc
> ppHsImportSpec (HsIVar name)                     = ppHsNameParen name
> ppHsImportSpec (HsIAbs name)                     = ppHsName name 
> ppHsImportSpec (HsIThingAll name)                = ppHsName name <> text"(..)"
> ppHsImportSpec (HsIThingWith name nameList)      = ppHsName name <>
>                                                    (parenList . map ppHsNameParen $ nameList)
> 
> -------------------------  Declarations ------------------------------
> ppHsDecl :: HsDecl -> Doc
> ppHsDecl (HsTypeDecl loc name nameList htype) = 
> 	   blankline $
> 	   mySep ( [text "type",ppHsName name] 
> 		   ++ map ppHsName nameList
> 		   ++ [equals, ppHsType htype])
> 
> ppHsDecl (HsDataDecl loc context name nameList constrList derives) = 
> 	   blankline $
>            mySep ([text "data", ppHsContext context, ppHsName name] 
>                   ++ map ppHsName nameList)
>                   <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))
>                                            (map ppHsConstr constrList))
>                        $$$ ppHsDeriving derives)
> 
> ppHsDecl (HsNewTypeDecl pos context name nameList constr derives) =
> 	   blankline $
>            mySep ([text "newtype", ppHsContext context, ppHsName name]
>                   ++ map ppHsName nameList)
>                   <+> equals <+> (ppHsConstr constr
>                                   $$$ ppHsDeriving derives)
> --m{spacing=False}
> -- special case for empty class declaration
> ppHsDecl (HsClassDecl pos qualType []) =
> 	   blankline $
> 	   mySep [text "class", ppHsQualType qualType]
> ppHsDecl (HsClassDecl pos qualType declList) =
> 	   blankline $
> 	   mySep [text "class", ppHsQualType qualType, text "where"]
> 	   $$$ body classIndent (map ppHsDecl declList)  
> 
> -- m{spacing=False}
> -- special case for empty instance declaration
> ppHsDecl (HsInstDecl pos qualType []) = 
> 	   blankline $
> 	   mySep [text "instance", ppHsQualType qualType]
> ppHsDecl (HsInstDecl pos qualType declList) = 
> 	   blankline $
> 	   mySep [text "instance", ppHsQualType qualType, text "where"]
> 	   $$$ body classIndent (map ppHsDecl declList)
> 		   
> ppHsDecl (HsDefaultDecl pos htype) = 
> 	   blankline $ 
> 	   text "default" <+> ppHsType htype
>  
> ppHsDecl (HsTypeSig pos nameList qualType) = 
> 	 blankline $ 
> 	 mySep ((punctuate comma . map ppHsNameParen $ nameList)
> 	       ++ [text "::", ppHsQualType qualType])
> 
> ppHsDecl (HsFunBind pos matches) 
>    = foldr ($$$) empty (map ppMatch matches)
> 
> ppHsDecl (HsPatBind pos pat rhs whereDecls)
>    = myFsep [ppHsPatOrOp pat, ppHsRhs rhs] $$$ ppWhere whereDecls
>     where
> 	-- special case for single operators
> 	ppHsPatOrOp (HsPVar n) = ppHsNameParen n
> 	ppHsPatOrOp p = ppHsPat p
> 
> ppHsDecl (HsInfixDecl pos assoc prec nameList) =
> 	   blankline $ 
> 	   mySep ([ppAssoc assoc, int prec]	
> 	     ++ (punctuate comma . map ppHsNameInfix $ nameList))
> 	    where
> 	    ppAssoc HsAssocNone  = text "infix"
> 	    ppAssoc HsAssocLeft  = text "infixl"
> 	    ppAssoc HsAssocRight = text "infixr"
> 
> ppMatch (HsMatch pos f ps rhs whereDecls)
>    =   myFsep (ppHsQNameParen f : map ppHsPat ps ++ [ppHsRhs rhs])
>    $$$ ppWhere whereDecls
> 
> ppWhere [] = empty
> ppWhere l = nest 2 (text "where" $$$ body whereIndent (map ppHsDecl l))
>         
> ------------------------- Data & Newtype Bodies -------------------------
> ppHsConstr :: HsConDecl -> Doc
> ppHsConstr (HsRecDecl pos name fieldList) =
> 	 ppHsName name
> 	 <> (braceList . map ppField $ fieldList)
> ppHsConstr (HsConDecl pos name typeList)
>      | isSymbolName name && length typeList == 2 =
> 	 let [l, r] = typeList in
> 	 myFsep [ppHsBangType l, ppHsName name, ppHsBangType r]
>      | otherwise =
> 	 mySep $ (ppHsName name) : 
> 		 map ppHsBangType typeList
> 
> ppField :: ([HsName],HsBangType) -> Doc
> ppField (names, ty) = myFsepSimple $  (punctuate comma . map ppHsName $ names) ++
> 			      [text "::", ppHsBangType ty]
> 	
> ppHsBangType :: HsBangType -> Doc
> ppHsBangType (HsBangedTy ty) = char '!' <> ppHsTypeArg ty
> ppHsBangType (HsUnBangedTy ty) = ppHsTypeArg ty
> 
> ppHsDeriving :: [HsQName] -> Doc
> ppHsDeriving []  = empty
> ppHsDeriving [d] = text "deriving" <+> ppHsQName d
> ppHsDeriving ds  = text "deriving" <+> parenList (map ppHsQName ds)
> 
> ------------------------- Types -------------------------
> ppHsQualType :: HsQualType -> Doc
> ppHsQualType (HsQualType context htype) = -- if it's HsQualType, context is never empty
> 	     myFsep [ ppHsContext context, text "=>", ppHsType htype]
> ppHsQualType (HsUnQualType htype) = ppHsType htype
> 
> parensIf :: Bool -> Doc -> Doc
> parensIf True = parens
> parensIf False = id
> 
> ppHsType :: HsType -> Doc
> ppHsType = ppHsTypePrec 0
> 
> ppHsTypeArg :: HsType -> Doc
> ppHsTypeArg = ppHsTypePrec 2
> 
> -- precedences:
> -- 0: top level
> -- 1: left argument of ->
> -- 2: argument of constructor
> 
> ppHsTypePrec :: Int -> HsType -> Doc
> ppHsTypePrec p (HsTyFun a b) =
> 	parensIf (p > 0) $
> 		myFsep [ppHsTypePrec 1 a, text "->", ppHsType b]
> ppHsTypePrec p (HsTyTuple l) = parenList . map ppHsType $ l
> -- special case
> ppHsTypePrec p (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsIdent "[]"))) b ) =
> 	brackets $ ppHsType b
> ppHsTypePrec p (HsTyApp a b) =
> 	parensIf (p > 1) $ myFsep[ppHsType a, ppHsTypeArg b]
> ppHsTypePrec p (HsTyVar name) = ppHsName name
> -- special case
> ppHsTypePrec p (HsTyCon (Qual (Module "Prelude") n)) = ppHsNameParen n
> ppHsTypePrec p (HsTyCon name) = ppHsQName name
> 
> ------------------------- Expressions -------------------------
> ppHsRhs :: HsRhs -> Doc
> ppHsRhs (HsUnGuardedRhs exp) = equals <+> ppHsExp exp
> ppHsRhs (HsGuardedRhss guardList) = 
> 	myVcat . map ppHsGuardedRhs $ guardList
> 
> ppHsGuardedRhs :: HsGuardedRhs -> Doc
> ppHsGuardedRhs (HsGuardedRhs pos guard body) = 
> 	       myFsep [ char '|',
> 		      ppHsExp guard,
> 		      equals,
> 		      ppHsExp body]
> 
> ppHsLit :: HsLiteral -> Doc
> ppHsLit	(HsInt i)      = integer i
> ppHsLit	(HsChar c)     = text (show c)
> ppHsLit	(HsString s)   = text (show s)
> ppHsLit	(HsFrac r)     = double (fromRational r)
> -- GHC unboxed literals:
> ppHsLit (HsCharPrim c)   = text (show c)           <> char '#'
> ppHsLit (HsStringPrim s) = text (show s)           <> char '#'
> ppHsLit (HsIntPrim i)    = integer i               <> char '#'
> ppHsLit (HsFloatPrim r)  = float  (fromRational r) <> char '#'
> ppHsLit (HsDoublePrim r) = double (fromRational r) <> text "##"
> -- GHC extension:
> ppHsLit (HsLitLit s)     = text "``" <> text s <> text "''"
> 
> ppHsExp :: HsExp -> Doc
> ppHsExp (HsLit l) = ppHsLit l
> -- lambda stuff
> ppHsExp (HsInfixApp a op b) = myFsep[ppHsExp a, ppInfix op, ppHsExp b]
> 	where 
> 	ppInfix (HsVar n) = ppHsQNameInfix n
> 	ppInfix (HsCon n) = ppHsQNameInfix n
> 	ppInfix n = error "illegal infix expression"
> ppHsExp (HsNegApp e) = myFsep [char '-', ppHsExp e]
> ppHsExp (HsApp a b) = myFsep [ppHsExp a, ppHsExp b]
> ppHsExp (HsLambda expList body) = myFsep $ 
> 	(((char '\\' ):) . map ppHsPat $ expList)
> 	++ [text "->", ppHsExp body]
> -- keywords
> ppHsExp (HsLet expList letBody) =
> 	myFsep [text "let" <+> body letIndent (map ppHsDecl expList),
> 		text "in", ppHsExp letBody]
> ppHsExp (HsIf cond thenexp elsexp) = 
> 	myFsep [text "if", ppHsExp cond,
> 	      text "then", ppHsExp thenexp,
> 	      text "else", ppHsExp elsexp]
> ppHsExp (HsCase cond altList) = myFsep[text "case", ppHsExp cond, text "of"]
> 			        $$$ body caseIndent (map ppHsAlt altList)
> ppHsExp (HsDo stmtList) = text "do" $$$ body doIndent (map ppHsStmt stmtList)
> -- Constructors & Vars
> ppHsExp (HsVar name) = ppHsQNameParen name
> ppHsExp (HsCon name) = ppHsQNameParen name
> ppHsExp (HsTuple expList) = parenList . map ppHsExp $ expList
> -- weird stuff
> ppHsExp (HsParen exp) = parens . ppHsExp $ exp
> ppHsExp (HsLeftSection (HsVar name) exp) =
> 	parens (ppHsExp exp <+> ppHsQNameInfix name)
> ppHsExp (HsLeftSection (HsCon name) exp) =
> 	parens (ppHsExp exp <+> ppHsQNameInfix name)
> ppHsExp (HsLeftSection _ _) = error "illegal left section"
> ppHsExp (HsRightSection exp (HsVar name)) =
> 	parens (ppHsQNameInfix name <+> ppHsExp exp)
> ppHsExp (HsRightSection exp (HsCon name)) =
> 	parens (ppHsQNameInfix name <+> ppHsExp exp)
> ppHsExp (HsRightSection _ _) = error "illegal right section"
> ppHsExp (HsRecConstr c fieldList) = 
> 	ppHsQName c
>         <> (braceList . map ppHsFieldUpdate  $ fieldList)
> ppHsExp (HsRecUpdate exp fieldList) = 
> 	ppHsExp exp
>         <> (braceList . map ppHsFieldUpdate  $ fieldList)
> -- patterns
> -- special case that would otherwise be buggy
> ppHsExp (HsAsPat name (HsIrrPat exp)) =
> 	myFsep[ppHsName name <> char '@', char '~' <> ppHsExp exp]
> ppHsExp (HsAsPat name exp) = hcat[ppHsName name,char '@',ppHsExp exp]
> ppHsExp HsWildCard = char '_'
> ppHsExp (HsIrrPat exp) = char '~' <> ppHsExp exp
> -- Lists
> ppHsExp (HsList list) = 
> 	bracketList . punctuate comma . map ppHsExp $ list
> ppHsExp (HsEnumFrom exp) =
> 	bracketList [ppHsExp exp,text ".."]
> ppHsExp (HsEnumFromTo from to) =
> 	bracketList [ppHsExp from, text "..", ppHsExp to]
> ppHsExp (HsEnumFromThen from thenE) = 
> 	bracketList [ppHsExp from <> comma, ppHsExp thenE]
> ppHsExp (HsEnumFromThenTo from thenE to) = 
> 	bracketList [ppHsExp from <> comma, ppHsExp thenE,
> 			text "..", ppHsExp to]
> ppHsExp (HsListComp exp stmtList) = 
> 	bracketList ([ppHsExp exp, char '|']
> 		++ (punctuate comma . map ppHsStmt $ stmtList))
> ppHsExp (HsExpTypeSig pos exp ty) = 
> 	myFsep[ppHsExp exp, text "::", ppHsQualType ty]
> 
> ------------------------- Patterns -----------------------------
> 
> ppHsPat :: HsPat -> Doc
> ppHsPat (HsPVar name) = ppHsNameParen name
> ppHsPat (HsPLit lit) = ppHsLit lit
> ppHsPat (HsPNeg p) = myFsep [char '-', ppHsPat p]
> ppHsPat (HsPInfixApp a op b) = myFsep[ppHsPat a, ppHsQNameInfix op, ppHsPat b]
> ppHsPat (HsPApp n ps) = myFsep (ppHsQName n : map ppHsPat ps)
> ppHsPat (HsPTuple ps) = parenList . map ppHsPat $ ps
> ppHsPat (HsPList ps) = bracketList . punctuate comma . map ppHsPat $ ps
> ppHsPat (HsPParen p) = parens . ppHsPat $ p
> ppHsPat (HsPRec c fields) 
>     =  ppHsQName c 
>     <> (braceList . map ppHsPatField $ fields)
> -- special case that would otherwise be buggy
> ppHsPat (HsPAsPat name (HsPIrrPat pat)) =
> 	myFsep[ppHsName name <> char '@', char '~' <> ppHsPat pat]
> ppHsPat	(HsPAsPat name pat) = hcat[ppHsName name,char '@',ppHsPat pat]
> ppHsPat	HsPWildCard = char '_'
> ppHsPat	(HsPIrrPat pat) = char '~' <> ppHsPat pat
> 
> ppHsPatField (HsPFieldPat name pat) = myFsep[ppHsQName name, equals, ppHsPat pat]
>   
> ------------------------- Case bodies  -------------------------
> ppHsAlt :: HsAlt -> Doc
> ppHsAlt (HsAlt pos exp gAlts decls) = 	
> 	ppHsPat exp <+> ppGAlts gAlts $$$ ppWhere decls
> 
> ppGAlts :: HsGuardedAlts -> Doc
> ppGAlts (HsUnGuardedAlt exp) = text "->" <+> ppHsExp exp
> ppGAlts (HsGuardedAlts altList) = myVcat . map ppGAlt $ altList
> 
> ppGAlt (HsGuardedAlt pos exp body) = 
> 	 myFsep [char '|', ppHsExp exp, text "->", ppHsExp body]
> 
> ------------------------- Statements in monads & list comprehensions -----
> ppHsStmt :: HsStmt -> Doc
> ppHsStmt (HsGenerator exp from) = 
> 	 ppHsPat exp <+> text "<-" <+> ppHsExp from
> ppHsStmt (HsQualifier exp) = ppHsExp exp
> ppHsStmt (HsLetStmt declList) = text "let" 
> 				$$$ body letIndent (map ppHsDecl declList)
> 
> ------------------------- Record updates
> ppHsFieldUpdate :: HsFieldUpdate -> Doc
> ppHsFieldUpdate (HsFieldUpdate name exp) = 
> 		  myFsep[ppHsQName name,equals,ppHsExp exp]
> 
> ------------------------- Names -------------------------
> ppHsQName :: HsQName -> Doc
> ppHsQName (UnQual name)			= ppHsName name
> ppHsQName (Qual m@(Module mod) name) 
> 	 | m == prelude_mod && isSpecialName name = ppHsName name
> 	 | otherwise = text mod <> char '.' <> ppHsName name
> 
> ppHsQNameParen :: HsQName -> Doc
> ppHsQNameParen name = parensIf (isSymbolName (getName name)) (ppHsQName name)
> 
> ppHsQNameInfix :: HsQName -> Doc
> ppHsQNameInfix name
> 	| isSymbolName (getName name) = ppHsQName name
> 	| otherwise = char '`' <> ppHsQName name <> char '`'
> 
> ppHsName :: HsName -> Doc
> ppHsName name = text (show name)
> 
> ppHsNameParen :: HsName -> Doc
> ppHsNameParen name = parensIf (isSymbolName name) (ppHsName name)
> 
> ppHsNameInfix :: HsName -> Doc
> ppHsNameInfix name
> 	| isSymbolName name = ppHsName name
> 	| otherwise = char '`' <> ppHsName name <> char '`'
> 
> isSymbolName :: HsName -> Bool
> isSymbolName (HsSymbol _) = True
> isSymbolName _ = False
> 
> isSpecialName :: HsName -> Bool
> isSpecialName (HsSpecial _) = True
> isSpecialName _ = False
> 
> getName :: HsQName -> HsName
> getName (UnQual s) = s
> getName (Qual _ s) = s
> 
> ppHsContext :: HsContext -> Doc
> ppHsContext []      = empty
> ppHsContext context = parenList (map ppHsAsst context)
> 
> -- hacked for multi-parameter type classes
> 
> ppHsAsst :: HsAsst -> Doc
> ppHsAsst (a,ts) = myFsep(ppHsQName a : map ppHsTypeArg ts)
> 
> ------------------------- pp utils -------------------------
> maybePP :: (a -> Doc) -> Maybe a -> Doc
> maybePP pp Nothing = empty
> maybePP pp (Just a) = pp a
> 
> parenList :: [Doc] -> Doc
> parenList = parens . myFsepSimple . punctuate comma
> 
> braceList :: [Doc] -> Doc
> braceList = braces . myFsepSimple . punctuate comma
> 
> bracketList :: [Doc] -> Doc
> bracketList = brackets . myFsepSimple
> 
> -- Monadic PP Combinators -- these examine the env
> 
> blankline :: Doc -> Doc
> blankline dl = do{e<-getPPEnv;if spacing e && layout e /= PPNoLayout
> 			      then space $$ dl else dl}
> topLevel :: Doc -> [Doc] -> Doc
> topLevel header dl = do 
> 	 e <- fmap layout getPPEnv
> 	 case e of 
> 	     PPOffsideRule -> header $$ vcat dl
> 	     PPSemiColon -> header $$ (braces . vcat . punctuate semi) dl
> 	     PPInLine -> header $$ (braces . vcat . punctuate semi) dl
> 	     PPNoLayout -> header <+> (braces . hsep . punctuate semi) dl
> 
> body :: (PPHsMode -> Int) -> [Doc] -> Doc
> body f dl = do
> 	 e <- fmap layout getPPEnv
> 	 case e of PPOffsideRule -> indent 
> 		   PPSemiColon   -> indentExplicit
> 		   _ -> inline
> 		   where
> 		   inline = braces . hsep . punctuate semi $ dl
> 		   indent  = do{i <-fmap f getPPEnv;nest i . vcat $ dl}
> 		   indentExplicit = do {i <- fmap f getPPEnv; 
> 			   nest i . braces . vcat . punctuate semi $ dl}
> 
> ($$$) :: Doc -> Doc -> Doc
> a $$$ b = layoutChoice (a $$) (a <+>) b
> 
> mySep :: [Doc] -> Doc
> mySep = layoutChoice mySep' hsep
> 	where			
> 	-- ensure paragraph fills with indentation.
> 	mySep' [x]    = x
> 	mySep' (x:xs) = x <+> fsep xs
> 	mySep' []     = error "Internal error: mySep"
> 
> myVcat :: [Doc] -> Doc
> myVcat = layoutChoice vcat hsep
> 
> myFsepSimple :: [Doc] -> Doc
> myFsepSimple = layoutChoice fsep hsep
> 
> -- same, except that continuation lines are indented,
> -- which is necessary to avoid triggering the offside rule.
> myFsep :: [Doc] -> Doc
> myFsep = layoutChoice fsep' hsep
> 	where	fsep' [] = empty
> 		fsep' (d:ds) = do
> 			e <- getPPEnv
> 			let n = onsideIndent e
> 			nest n (fsep (nest (-n) d:ds))
> 
> layoutChoice a b dl = do e <- getPPEnv
>                          if layout e == PPOffsideRule ||
>                             layout e == PPSemiColon
>                           then a dl else b dl
