2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
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(..), UfAlt, UfBinder(..), UfNote(..),
16 UfBinding(..), UfCon(..)
19 #include "HsVersions.h"
22 import HsTypes ( HsType, pprParendHsType )
25 import Const ( Literal )
31 %************************************************************************
33 \subsection[HsCore-types]{Types for read/written Core unfoldings}
35 %************************************************************************
40 | UfType (HsType name)
41 | UfCon (UfCon name) [UfExpr name]
42 | UfTuple name [UfExpr name] -- Type arguments omitted
43 | UfLam (UfBinder name) (UfExpr name)
44 | UfApp (UfExpr name) (UfExpr name)
45 | UfCase (UfExpr name) name [UfAlt name]
46 | UfLet (UfBinding name) (UfExpr name)
47 | UfNote (UfNote name) (UfExpr name)
49 data UfNote name = UfSCC CostCentre
50 | UfCoerce (HsType name)
53 type UfAlt name = (UfCon name, [name], UfExpr name)
55 data UfCon name = UfDefault
58 | UfLitLitCon FAST_STRING (HsType name)
60 | UfCCallOp FAST_STRING -- callee
61 Bool -- True <=> casm, rather than ccall
62 Bool -- True <=> might cause GC
65 = UfNonRec (UfBinder name)
67 | UfRec [(UfBinder name, UfExpr name)]
70 = UfValBinder name (HsType name)
71 | UfTyBinder name Kind
75 %************************************************************************
77 \subsection[HsCore-print]{Printing Core unfoldings}
79 %************************************************************************
82 instance Outputable name => Outputable (UfExpr name) where
84 ppr (UfType ty) = char '@' <+> pprParendHsType ty
87 = hsep [text "UfCon", ppr c, ppr as]
89 ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
92 = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
94 ppr (UfApp fun arg) = ppr fun <+> ppr arg
96 ppr (UfCase scrut bndr alts)
97 = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
98 braces (hsep (punctuate semi (map pp_alt alts)))]
100 pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
102 ppr_arrow = ptext SLIT("->")
104 ppr (UfLet (UfNonRec b rhs) body)
105 = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
106 ppr (UfLet (UfRec pairs) body)
107 = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
109 pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
111 ppr (UfNote note body)
112 = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
114 instance Outputable name => Outputable (UfCon name) where
115 ppr UfDefault = text "DEFAULT"
116 ppr (UfDataCon d) = ppr d
117 ppr (UfPrimOp p) = ppr p
118 ppr (UfCCallOp str is_casm can_gc)
119 = hcat [before, ptext str, after]
121 before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
122 after = if is_casm then text "'' " else space
124 instance Outputable name => Outputable (UfBinder name) where
125 ppr (UfValBinder name ty) = hsep [ppr name, ptext SLIT("::"), ppr ty]
126 ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]