Pretty.hs 6.04 KB
Newer Older
1
2
3
4
5
{- |
    Module      :  $Header$
    Description :  Pretty printer for IL
    Copyright   :  (c) 1999 - 2003 Wolfgang Lux
                                   Martin Engelke
6
                       2011 - 2015 Björn Peemöller
7
                       2017        Finn Teegen
8
    License     :  BSD-3-clause
9
10
11
12
13
14
15
16
17
18

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

   This module implements just another pretty printer, this time for the
   intermediate language. It was mainly adapted from the Curry pretty
   printer which, in turn, is based on Simon Marlow's pretty printer
   for Haskell.
-}
Finn Teegen's avatar
Finn Teegen committed
19
{-# LANGUAGE CPP #-}
20
21
module IL.Pretty (ppModule) where

Finn Teegen's avatar
Finn Teegen committed
22
23
24
25
#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
import Curry.Base.Ident
import Curry.Base.Pretty
import IL.Type

dataIndent :: Int
dataIndent = 2

bodyIndent :: Int
bodyIndent = 2

exprIndent :: Int
exprIndent = 2

caseIndent :: Int
caseIndent = 2

altIndent :: Int
altIndent = 2

orIndent :: Int
orIndent = 2

ppModule :: Module -> Doc
ppModule (Module m is ds) = sepByBlankLine
  [ppHeader m, vcat (map ppImport is), sepByBlankLine (map ppDecl ds)]

ppHeader :: ModuleIdent -> Doc
53
ppHeader m = text "module" <+> text (moduleName m) <+> text "where"
54
55

ppImport :: ModuleIdent -> Doc
56
ppImport m = text "import" <+> text (moduleName m)
57
58
59
60
61
62

ppDecl :: Decl -> Doc
ppDecl (DataDecl                   tc n cs) = sep $
  text "data" <+> ppTypeLhs tc n :
  map (nest dataIndent)
      (zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs))
63
64
ppDecl (ExternalDataDecl              tc n) =
  text "external data" <+> ppTypeLhs tc n
65
ppDecl (FunctionDecl             f vs ty e) = ppTypeSig f ty $$ sep
66
  [ ppQIdent f <+> hsep (map (ppIdent . snd) vs) <+> equals
67
  , nest bodyIndent (ppExpr 0 e)]
Finn Teegen's avatar
Finn Teegen committed
68
ppDecl (ExternalDecl f ty) = text "external" <+> ppTypeSig f ty
69
70
71
72

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

Finn Teegen's avatar
Finn Teegen committed
73
ppConstr :: ConstrDecl -> Doc
74
75
76
77
78
79
80
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)
Finn Teegen's avatar
Finn Teegen committed
81
  | isQTupleId tc                    = parens
82
    (fsep (punctuate comma (map (ppType 0) tys)))
Finn Teegen's avatar
Finn Teegen committed
83
84
85
  | tc == qListId && length tys == 1 = brackets (ppType 0 (head tys))
  | otherwise                        = parenIf (p > 1 && not (null tys))
    (ppQIdent tc <+> fsep (map (ppType 2) tys))
86
ppType _ (TypeVariable    n) = ppTypeVar n
87
ppType p (TypeArrow ty1 ty2) = parenIf (p > 0)
88
89
90
91
                               (fsep (ppArrow (TypeArrow ty1 ty2)))
  where
  ppArrow (TypeArrow ty1' ty2') = ppType 1 ty1' <+> text "->" : ppArrow ty2'
  ppArrow ty                    = [ppType 0 ty]
92
93
94
95
96
97
98
99
100
101
102
103
104
ppType p (TypeForall ns ty)
  | null ns   = ppType p ty
  | otherwise = parenIf (p > 0) $ ppQuantifiedTypeVars ns <+> ppType 0 ty

ppTypeVar :: Int -> Doc
ppTypeVar n
  | n >= 0    = text (typeVars !! n)
  | otherwise = text ('_':show (-n))

ppQuantifiedTypeVars :: [Int] -> Doc
ppQuantifiedTypeVars ns
  | null ns = empty
  | otherwise = text "forall" <+> hsep (map ppTypeVar ns) <+> char '.'
105
106
107
108
109
110
111
112
113
114

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

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

ppLiteral :: Literal -> Doc
Finn Teegen's avatar
Finn Teegen committed
115
116
117
ppLiteral (Char  c) = text (show c)
ppLiteral (Int   i) = integer i
ppLiteral (Float f) = double f
118
119

ppConstrTerm :: ConstrTerm -> Doc
120
121
ppConstrTerm (LiteralPattern     _                    l) = ppLiteral l
ppConstrTerm (ConstructorPattern _ c [(_, v1), (_, v2)])
122
  | isQInfixOp c = ppIdent v1 <+> ppQInfixOp c <+> ppIdent v2
123
124
125
126
ppConstrTerm (ConstructorPattern _ c                 vs)
  | isQTupleId c = parens $ fsep (punctuate comma $ map (ppIdent . snd) vs)
  | otherwise    = ppQIdent c <+> fsep (map (ppIdent . snd) vs)
ppConstrTerm (VariablePattern    _                    v) = ppIdent v
127
128

ppExpr :: Int -> Expression -> Doc
129
130
131
132
133
ppExpr _ (Literal       _ l) = ppLiteral l
ppExpr _ (Variable      _ v) = ppIdent v
ppExpr _ (Function    _ f _) = ppQIdent f
ppExpr _ (Constructor _ c _) = ppQIdent c
ppExpr p (Apply (Apply (Function    _ f _) e1) e2)
134
  | isQInfixOp f = ppInfixApp p e1 f e2
135
ppExpr p (Apply (Apply (Constructor _ c _) e1) e2)
136
  | isQInfixOp c = ppInfixApp p e1 c e2
137
ppExpr p (Apply       e1 e2) = parenIf (p > 2) $ sep
138
  [ppExpr 2 e1, nest exprIndent (ppExpr 3 e2)]
139
ppExpr p (Case    ev e alts) = parenIf (p > 0) $
140
141
142
143
  text "case" <+> ppEval ev <+> ppExpr 0 e <+> text "of"
  $$ nest caseIndent (vcat $ map ppAlt alts)
  where ppEval Rigid = text "rigid"
        ppEval Flex  = text "flex"
144
ppExpr p (Or          e1 e2) = parenIf (p > 0) $ sep
145
  [nest orIndent (ppExpr 0 e1), char '|', nest orIndent (ppExpr 0 e2)]
146
ppExpr p (Exist       v _ e) = parenIf (p > 0) $ sep
147
  [text "let" <+> ppIdent v <+> text "free" <+> text "in", ppExpr 0 e]
148
ppExpr p (Let           b e) = parenIf (p > 0) $ sep
149
  [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e]
150
ppExpr p (Letrec       bs e) = parenIf (p > 0) $ sep
151
  [text "letrec" <+> vcat (map ppBinding bs) <+> text "in", ppExpr 0 e]
152
ppExpr p (Typed        e ty) = parenIf (p > 0) $ sep
153
154
155
  [ppExpr 0 e, text "::", ppType 0 ty]

ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc
156
ppInfixApp p e1 op e2 = parenIf (p > 1) $ sep
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
  [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 (idName x)

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

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