% $Id: ILPP.lhs,v 1.22 2003/10/28 05:43:43 wlux Exp $
%
% Copyright (c) 1999-2003 Wolfgang Lux
% See LICENSE for the full license.
%
% Modified by Martin Engelke (men@informatik.uni-kiel.de)
%
\nwfilename{ILPP.lhs}
\section{A pretty printer for the intermediate language}
This module implements just another pretty printer, this time for the
intermediate language. It was mainly adapted from the Curry pretty
printer (see sect.~\ref{sec:CurryPP}) which, in turn, is based on Simon
Marlow's pretty printer for Haskell.
\begin{verbatim}

> module IL.Pretty(ppModule)  where
> 
> import Text.PrettyPrint.HughesPJ

> import Curry.Base.Ident
> import IL.Type

> default(Int,Double)

> dataIndent = 2
> bodyIndent = 2
> exprIndent = 2
> caseIndent = 2
> altIndent = 2

> ppModule :: Module -> Doc
> ppModule (Module m is ds) =
>   vcat (text "module" <+> text (show m) <+> text "where" :
>         map ppImport is ++ map ppDecl ds)

> ppImport :: ModuleIdent -> Doc
> ppImport m = text "import" <+> text (show m)

> ppDecl :: Decl -> Doc
> ppDecl (DataDecl tc n cs) =
>   sep (text "data" <+> ppTypeLhs tc n :
>        map (nest dataIndent)
>            (zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs)))
> ppDecl (NewtypeDecl tc n (ConstrDecl c ty)) =
>   sep [text "newtype" <+> ppTypeLhs tc n <+> equals,
>        nest dataIndent (ppConstr (ConstrDecl c [ty]))]
> ppDecl (FunctionDecl f vs ty exp) =
>   ppTypeSig f ty $$
>   sep [ppQIdent f <+> hsep (map ppIdent vs) <+> equals,
>        nest bodyIndent (ppExpr 0 exp)]
> ppDecl (ExternalDecl f cc ie ty) =
>   sep [text "external" <+> ppCallConv cc <+> text (show ie),
>        nest bodyIndent (ppTypeSig f ty)]
>   where ppCallConv Primitive = text "primitive"
>         ppCallConv CCall = text "ccall"

> ppTypeLhs :: QualIdent -> Int -> Doc
> ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars))

> ppConstr :: ConstrDecl [Type] -> Doc
> ppConstr (ConstrDecl c tys) = ppQIdent c <+> fsep (map (ppType 2) tys)

> ppTypeSig :: QualIdent -> Type -> Doc
> ppTypeSig f ty = ppQIdent f <+> text "::" <+> ppType 0 ty

> ppType :: Int -> Type -> Doc
> ppType p (TypeConstructor tc tys)
>   | isQTupleId tc = parens (fsep (punctuate comma (map (ppType 0) tys)))
>   | unqualify tc == nilId = brackets (ppType 0 (head tys))
>   | otherwise =
>       ppParen (p > 1 && not (null tys))
>               (ppQIdent tc <+> fsep (map (ppType 2) tys))
> ppType _ (TypeVariable n)
>   | n >= 0 = text (typeVars !! n)
>   | otherwise = text ('_':show (-n))
> ppType p (TypeArrow ty1 ty2) =
>   ppParen (p > 0) (fsep (ppArrow (TypeArrow ty1 ty2)))
>   where ppArrow (TypeArrow ty1 ty2) =
>           ppType 1 ty1 <+> text "->" : ppArrow ty2
>         ppArrow ty = [ppType 0 ty]

> ppBinding :: Binding -> Doc
> ppBinding (Binding v exp) =
>   sep [ppIdent v <+> equals,nest bodyIndent (ppExpr 0 exp)]

> ppAlt :: Alt -> Doc
> ppAlt (Alt pat exp) =
>   sep [ppConstrTerm pat <+> text "->",nest altIndent (ppExpr 0 exp)]

> ppLiteral :: Literal -> Doc
> ppLiteral (Char _ c) = text (show c)
> ppLiteral (Int _ i) = integer i
> ppLiteral (Float _ f) = double f

> ppConstrTerm :: ConstrTerm -> Doc
> ppConstrTerm (LiteralPattern l) = ppLiteral l
> ppConstrTerm (ConstructorPattern c [v1,v2])
>   | isQInfixOp c = ppIdent v1 <+> ppQInfixOp c <+> ppIdent v2
> ppConstrTerm (ConstructorPattern c vs)
>   | isQTupleId c = parens (fsep (punctuate comma (map ppIdent vs)))
>   | otherwise = ppQIdent c <+> fsep (map ppIdent vs)
> ppConstrTerm (VariablePattern v) = ppIdent v

> ppExpr :: Int -> Expression -> Doc
> ppExpr p (Literal l) = ppLiteral l
> ppExpr p (Variable v) = ppIdent v
> ppExpr p (Function f _) = ppQIdent f
> ppExpr p (Constructor c _) = ppQIdent c
> ppExpr p (Apply (Apply (Function f _) e1) e2)
>   | isQInfixOp f = ppInfixApp p e1 f e2
> ppExpr p (Apply (Apply (Constructor c _) e1) e2)
>   | isQInfixOp c = ppInfixApp p e1 c e2
> ppExpr p (Apply e1 e2) =
>   ppParen (p > 2) (sep [ppExpr 2 e1,nest exprIndent (ppExpr 3 e2)])
> ppExpr p (Case _ ev e alts) =
>   ppParen (p > 0)
>           (text "case" <+> ppEval ev <+> ppExpr 0 e <+> text "of" $$
>            nest caseIndent (vcat (map ppAlt alts)))
>   where ppEval Rigid = text "rigid"
>         ppEval Flex = text "flex"
> ppExpr p (Or e1 e2) =
>   ppParen (p > 0) (sep [ppExpr 0 e1,char '|' <+> ppExpr 0 e2])
> ppExpr p (Exist v e) =
>   ppParen (p > 0)
>           (sep [text "let" <+> ppIdent v <+> text "free" <+> text "in",
>                 ppExpr 0 e])
> ppExpr p (Let b e) =
>   ppParen (p > 0) (sep [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e])
> ppExpr p (Letrec bs e) =
>   ppParen (p > 0)
>           (sep [text "letrec" <+> vcat (map ppBinding bs) <+> text "in",
>                 ppExpr 0 e])

> ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc
> ppInfixApp p e1 op e2 =
>   ppParen (p > 1)
>           (sep [ppExpr 2 e1 <+> ppQInfixOp op,nest exprIndent (ppExpr 2 e2)])

> ppIdent :: Ident -> Doc
> ppIdent ident
>   | isInfixOp ident = parens (ppName ident)
>   | otherwise = ppName ident

> ppQIdent :: QualIdent -> Doc
> ppQIdent ident
>   | isQInfixOp ident = parens (ppQual ident)
>   | otherwise = ppQual ident

> ppQInfixOp :: QualIdent -> Doc
> ppQInfixOp op
>   | isQInfixOp op = ppQual op
>   | otherwise = char '`' <> ppQual op <> char '`'

> ppName :: Ident -> Doc
> ppName x = text (name x)

> ppQual :: QualIdent -> Doc
> ppQual x = text (qualName x)

> typeVars :: [String]
> typeVars = [mkTypeVar c i | i <- [0..], c <- ['a' .. 'z']]
>   where mkTypeVar c i = c : if i == 0 then [] else show i

> ppParen :: Bool -> Doc -> Doc
> ppParen p = if p then parens else id

\end{verbatim}