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(..), UfConAlt(..),
17 HsIdInfo(..), HsStrictnessInfo(..),
18 IfaceSig(..), UfRuleBody(..)
21 #include "HsVersions.h"
24 import HsTypes ( HsType, pprParendHsType )
27 import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo )
28 import CoreSyn ( CoreBndr, CoreExpr )
29 import Demand ( Demand )
30 import Literal ( Literal )
31 import PrimOp ( CCall, pprCCallOp )
33 import PprType ( {- instance Outputable Kind -} )
35 import SrcLoc ( SrcLoc )
39 %************************************************************************
41 \subsection[HsCore-types]{Types for read/written Core unfoldings}
43 %************************************************************************
48 | UfType (HsType name)
49 | UfTuple name [UfExpr name] -- Type arguments omitted
50 | UfLam (UfBinder name) (UfExpr name)
51 | UfApp (UfExpr name) (UfExpr name)
52 | UfCase (UfExpr name) name [UfAlt name]
53 | UfLet (UfBinding name) (UfExpr name)
54 | UfNote (UfNote name) (UfExpr name)
56 | UfLitLit FAST_STRING (HsType name)
57 | UfCCall CCall (HsType name)
59 data UfNote name = UfSCC CostCentre
60 | UfCoerce (HsType name)
64 type UfAlt name = (UfConAlt name, [name], UfExpr name)
66 data UfConAlt name = UfDefault
69 | UfLitLitAlt FAST_STRING (HsType name)
72 = UfNonRec (UfBinder name)
74 | UfRec [(UfBinder name, UfExpr name)]
77 = UfValBinder name (HsType name)
78 | UfTyBinder name Kind
82 %************************************************************************
84 \subsection[HsCore-print]{Printing Core unfoldings}
86 %************************************************************************
89 instance Outputable name => Outputable (UfExpr name) where
93 ppr (UfLitLit l ty) = ppr l
94 ppr (UfCCall cc ty) = pprCCallOp cc
96 ppr (UfType ty) = char '@' <+> pprParendHsType ty
98 ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
101 = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
103 ppr (UfApp fun arg) = ppr fun <+> ppr arg
105 ppr (UfCase scrut bndr alts)
106 = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
107 braces (hsep (punctuate semi (map pp_alt alts)))]
109 pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
111 ppr_arrow = ptext SLIT("->")
113 ppr (UfLet (UfNonRec b rhs) body)
114 = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
115 ppr (UfLet (UfRec pairs) body)
116 = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
118 pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
120 ppr (UfNote note body)
121 = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
123 instance Outputable name => Outputable (UfConAlt name) where
124 ppr UfDefault = text "DEFAULT"
125 ppr (UfLitAlt l) = ppr l
126 ppr (UfLitLitAlt l ty) = ppr l
127 ppr (UfDataAlt d) = ppr d
129 instance Outputable name => Outputable (UfBinder name) where
130 ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty]
131 ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
135 %************************************************************************
137 \subsection{Signatures in interface files}
139 %************************************************************************
148 instance (Outputable name) => Outputable (IfaceSig name) where
149 ppr (IfaceSig var ty info _)
150 = hang (hsep [ppr var, dcolon])
151 4 (ppr ty $$ ifPprDebug (vcat (map ppr info)))
155 | HsStrictness HsStrictnessInfo
156 | HsUnfold InlinePragInfo (UfExpr name)
157 | HsUpdate UpdateInfo
158 | HsSpecialise (UfRuleBody name)
161 | HsWorker name -- Worker, if any
163 instance Outputable name => Outputable (HsIdInfo name) where
164 ppr (HsUnfold _ unf) = ptext (SLIT("Unfolding:")) <+> ppr unf
165 ppr other = empty -- Havn't got around to this yet
167 data HsStrictnessInfo
168 = HsStrictnessInfo ([Demand], Bool)
173 %************************************************************************
175 \subsection{Rules in interface files}
177 %************************************************************************
180 data UfRuleBody name = UfRuleBody FAST_STRING [UfBinder name] [UfExpr name] (UfExpr name) -- Pre typecheck
181 | CoreRuleBody FAST_STRING [CoreBndr] [CoreExpr] CoreExpr -- Post typecheck