2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 %************************************************************************
6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
8 %************************************************************************
10 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
11 @TyVars@ as well. Currently trying the former... MEGA SIGH.
15 UfExpr(..), UfAlts(..), UfBinder(..), UfNote(..),
16 UfDefault(..), UfBinding(..),
17 UfArg(..), UfPrimOp(..)
20 #include "HsVersions.h"
23 import HsTypes ( HsType, pprParendHsType )
24 import Kind ( Kind {- instance Outputable -} )
27 import Literal ( Literal )
33 %************************************************************************
35 \subsection[HsCore-types]{Types for read/written Core unfoldings}
37 %************************************************************************
43 | UfCon name [UfArg name]
44 | UfPrim (UfPrimOp name) [UfArg name]
45 | UfLam (UfBinder name) (UfExpr name)
46 | UfApp (UfExpr name) (UfArg name)
47 | UfCase (UfExpr name) (UfAlts name)
48 | UfLet (UfBinding name) (UfExpr name)
49 | UfNote (UfNote name) (UfExpr name)
52 = UfCCallOp FAST_STRING -- callee
53 Bool -- True <=> casm, rather than ccall
54 Bool -- True <=> might cause GC
55 [HsType name] -- arg types, incl state token
56 -- (which will be first)
57 (HsType name) -- return type
61 data UfNote name = UfSCC CostCentre
62 | UfCoerce (HsType name)
66 = UfAlgAlts [(name, [name], UfExpr name)]
68 | UfPrimAlts [(Literal, UfExpr name)]
73 | UfBindDefault name (UfExpr name)
76 = UfNonRec (UfBinder name)
78 | UfRec [(UfBinder name, UfExpr name)]
81 = UfValBinder name (HsType name)
82 | UfTyBinder name Kind
87 | UfTyArg (HsType name)
90 %************************************************************************
92 \subsection[HsCore-print]{Printing Core unfoldings}
94 %************************************************************************
97 instance Outputable name => Outputable (UfExpr name) where
102 = hsep [text "UfCon", ppr c, ppr as, char ')']
104 = hsep [text "UfPrim", ppr o, ppr as, char ')']
107 = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
109 ppr (UfApp fun (UfTyArg ty))
110 = hsep [ppr fun, char '@', pprParendHsType ty]
112 ppr (UfApp fun (UfLitArg lit))
113 = hsep [ppr fun, ppr lit]
115 ppr (UfApp fun (UfVarArg var))
116 = hsep [ppr fun, ppr var]
118 ppr (UfCase scrut alts)
119 = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of {"), pp_alts alts, char '}']
121 pp_alts (UfAlgAlts alts deflt)
122 = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
124 pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
125 pp_alts (UfPrimAlts alts deflt)
126 = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
128 pp_alt (l,rhs) = hsep [ppr l, ppr_arrow, ppr rhs]
130 pp_deflt UfNoDefault = empty
131 pp_deflt (UfBindDefault b rhs) = hsep [ppr b, ppr_arrow, ppr rhs]
133 ppr_arrow = ptext SLIT("->")
135 ppr (UfLet (UfNonRec b rhs) body)
136 = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
137 ppr (UfLet (UfRec pairs) body)
138 = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
140 pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
142 ppr (UfNote note body)
143 = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
145 instance Outputable name => Outputable (UfPrimOp name) where
146 ppr (UfCCallOp str is_casm can_gc arg_tys result_ty)
148 before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
149 after = if is_casm then text "'' " else space
151 hcat [before, ptext str, after,
152 brackets (ppr arg_tys), space, ppr result_ty]
157 instance Outputable name => Outputable (UfArg name) where
158 ppr (UfVarArg v) = ppr v
159 ppr (UfLitArg l) = ppr l
160 ppr (UfTyArg ty) = pprParendHsType ty
162 instance Outputable name => Outputable (UfBinder name) where
163 ppr (UfValBinder name ty) = hsep [ppr name, ptext SLIT("::"), ppr ty]
164 ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]