2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[HsDecls]{Abstract syntax: global declarations}
6 Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
7 @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
11 HsDecl(..), TyClDecl(..), InstDecl(..),
12 DefaultDecl(..), ForeignDecl(..), ForKind(..),
13 ExtName(..), isDynamic,
14 ConDecl(..), ConDetails(..), BangType(..),
15 IfaceSig(..), SpecDataSig(..), HsIdInfo(..), HsStrictnessInfo(..),
16 hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls
19 #include "HsVersions.h"
22 import HsBinds ( HsBinds, MonoBinds, Sig, FixitySig(..), nullMonoBinds )
23 import HsPragmas ( DataPragmas, ClassPragmas )
25 import HsCore ( UfExpr )
26 import BasicTypes ( Fixity, NewOrData(..) )
27 import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo )
28 import Demand ( Demand )
29 import CallConv ( CallConv, pprCallConv )
32 import Name ( NamedThing )
34 import SrcLoc ( SrcLoc )
39 %************************************************************************
41 \subsection[HsDecl]{Declarations}
43 %************************************************************************
47 = TyClD (TyClDecl name pat)
48 | InstD (InstDecl name pat)
49 | DefD (DefaultDecl name)
50 | ValD (HsBinds name pat)
51 | ForD (ForeignDecl name)
52 | SigD (IfaceSig name)
53 | FixD (FixitySig name)
55 -- NB: all top-level fixity decls are contained EITHER
57 -- OR in the ClassDecls in TyClDs
60 -- a) data constructors
61 -- b) class methods (but they can be also done in the
62 -- signatures of class decls)
63 -- c) imported functions (that have an IfacSig)
66 -- The latter is for class methods only
68 -- It's a bit wierd that the fixity decls in the ValD
69 -- cover all the classops and imported decls too, but it's convenient
70 -- For a start, it means we don't need a FixD
75 hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
76 => HsDecl name pat -> name
78 hsDeclName (TyClD decl) = tyClDeclName decl
79 hsDeclName (SigD (IfaceSig name _ _ _)) = name
80 hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
81 hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
82 hsDeclName (FixD (FixitySig name _ _)) = name
83 -- Others don't make sense
85 hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
88 tyClDeclName :: TyClDecl name pat -> name
89 tyClDeclName (TyData _ _ name _ _ _ _ _) = name
90 tyClDeclName (TySynonym name _ _ _) = name
91 tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _) = name
95 instance (NamedThing name, Outputable name, Outputable pat)
96 => Outputable (HsDecl name pat) where
98 ppr (TyClD dcl) = ppr dcl
99 ppr (SigD sig) = ppr sig
100 ppr (ValD binds) = ppr binds
101 ppr (DefD def) = ppr def
102 ppr (InstD inst) = ppr inst
103 ppr (ForD fd) = ppr fd
104 ppr (FixD fd) = ppr fd
106 {- Why do we need ordering on decls?
109 -- hsDeclName needs more context when DEBUG is on
110 instance (NamedThing name, Outputable name, Outputable pat, Eq name)
111 => Eq (HsDecl name pat) where
112 d1 == d2 = hsDeclName d1 == hsDeclName d2
114 instance (NamedThing name, Outputable name, Outputable pat, Ord name)
115 => Ord (HsDecl name pat) where
116 d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
118 instance (Eq name) => Eq (HsDecl name pat) where
119 d1 == d2 = hsDeclName d1 == hsDeclName d2
121 instance (Ord name) => Ord (HsDecl name pat) where
122 d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
128 %************************************************************************
130 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
132 %************************************************************************
135 data TyClDecl name pat
137 (Context name) -- context
138 name -- type constructor
139 [HsTyVar name] -- type variables
140 [ConDecl name] -- data constructors (empty if abstract)
141 (Maybe [name]) -- derivings; Nothing => not specified
142 -- (i.e., derive default); Just [] => derive
143 -- *nothing*; Just <list> => as you would
148 | TySynonym name -- type constructor
149 [HsTyVar name] -- type variables
150 (HsType name) -- synonym expansion
153 | ClassDecl (Context name) -- context...
154 name -- name of the class
155 [HsTyVar name] -- the class type variables
156 [Sig name] -- methods' signatures
157 (MonoBinds name pat) -- default methods
159 name name -- The names of the tycon and datacon for this class
160 -- These are filled in by the renamer
165 countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
166 -- class, data, newtype, synonym decls
168 = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ <- decls],
169 length [() | TyData DataType _ _ _ _ _ _ _ <- decls],
170 length [() | TyData NewType _ _ _ _ _ _ _ <- decls],
171 length [() | TySynonym _ _ _ _ <- decls])
173 isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
175 isSynDecl (TySynonym _ _ _ _) = True
176 isSynDecl other = False
178 isDataDecl (TyData _ _ _ _ _ _ _ _) = True
179 isDataDecl other = False
181 isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _) = True
182 isClassDecl other = False
186 instance (NamedThing name, Outputable name, Outputable pat)
187 => Outputable (TyClDecl name pat) where
189 ppr (TySynonym tycon tyvars mono_ty src_loc)
190 = hang (pp_decl_head SLIT("type") empty tycon tyvars)
193 ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
195 (pp_decl_head keyword (pprContext context) tycon tyvars)
196 (pp_condecls condecls)
199 keyword = case new_or_data of
200 NewType -> SLIT("newtype")
201 DataType -> SLIT("data")
203 ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
204 | null sigs -- No "where" part
207 | otherwise -- Laid out
208 = sep [hsep [top_matter, ptext SLIT("where {")],
209 nest 4 (vcat [sep (map ppr_sig sigs),
213 top_matter = hsep [ptext SLIT("class"), pprContext context,
214 ppr clas, hsep (map (ppr) tyvars)]
215 ppr_sig sig = ppr sig <> semi
218 pp_decl_head str pp_context tycon tyvars
219 = hsep [ptext str, pp_context, ppr tycon,
220 interppSP tyvars, ptext SLIT("=")]
222 pp_condecls [] = empty -- Curious!
223 pp_condecls (c:cs) = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
225 pp_tydecl pp_head pp_decl_rhs derivings
226 = hang pp_head 4 (sep [
230 Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
234 A type for recording what types a datatype should be specialised to.
235 It's called a ``Sig'' because it's sort of like a ``type signature''
236 for an datatype declaration.
239 data SpecDataSig name
240 = SpecDataSig name -- tycon to specialise
244 instance (NamedThing name, Outputable name)
245 => Outputable (SpecDataSig name) where
247 ppr (SpecDataSig tycon ty _)
248 = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
251 %************************************************************************
253 \subsection[ConDecl]{A data-constructor declaration}
255 %************************************************************************
259 = ConDecl name -- Constructor name
261 [HsTyVar name] -- Existentially quantified type variables
262 (Context name) -- ...and context
263 -- If both are empty then there are no existentials
269 = VanillaCon -- prefix-style con decl
272 | InfixCon -- infix-style con decl
276 | RecCon -- record-style con decl
277 [([name], BangType name)] -- list of "fields"
279 | NewCon -- newtype con decl
283 = Banged (HsType name) -- HsType: to allow Haskell extensions
284 | Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
288 instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
289 ppr (ConDecl con tvs cxt con_details loc)
290 = sep [pprForAll tvs, pprContext cxt, ppr_con_details con con_details]
292 ppr_con_details con (InfixCon ty1 ty2)
293 = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
295 ppr_con_details con (VanillaCon tys)
296 = ppr con <+> hsep (map (ppr_bang) tys)
298 ppr_con_details con (NewCon ty)
299 = ppr con <+> pprParendHsType ty
301 ppr_con_details con (RecCon fields)
302 = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
304 ppr_field (ns, ty) = hsep (map (ppr) ns) <+>
308 ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty
309 ppr_bang (Unbanged ty) = pprParendHsType ty
313 %************************************************************************
315 \subsection[InstDecl]{An instance declaration
317 %************************************************************************
320 data InstDecl name pat
321 = InstDecl (HsType name) -- Context => Class Instance-type
322 -- Using a polytype means that the renamer conveniently
323 -- figures out the quantified type variables for us.
327 [Sig name] -- User-supplied pragmatic info
329 (Maybe name) -- Name for the dictionary function
335 instance (NamedThing name, Outputable name, Outputable pat)
336 => Outputable (InstDecl name pat) where
338 ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
339 = getPprStyle $ \ sty ->
340 if ifaceStyle sty || (nullMonoBinds binds && null uprags) then
341 hsep [ptext SLIT("instance"), ppr inst_ty]
343 vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
349 %************************************************************************
351 \subsection[DefaultDecl]{A @default@ declaration}
353 %************************************************************************
355 There can only be one default declaration per module, but it is hard
356 for the parser to check that; we pass them all through in the abstract
357 syntax, and that restriction must be checked in the front end.
360 data DefaultDecl name
361 = DefaultDecl [HsType name]
364 instance (NamedThing name, Outputable name)
365 => Outputable (DefaultDecl name) where
367 ppr (DefaultDecl tys src_loc)
368 = ptext SLIT("default") <+> parens (interpp'SP tys)
371 %************************************************************************
373 \subsection{Foreign function interface declaration}
375 %************************************************************************
378 data ForeignDecl name =
387 instance (NamedThing name, Outputable name)
388 => Outputable (ForeignDecl name) where
390 ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
391 = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+>
392 ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
394 (ppr_imp_exp, ppr_unsafe) =
396 FoLabel -> (ptext SLIT("label"), empty)
397 FoExport -> (ptext SLIT("export"), empty)
399 | us -> (ptext SLIT("import"), ptext SLIT("unsafe"))
400 | otherwise -> (ptext SLIT("import"), empty)
405 | FoImport Bool -- True => unsafe call.
409 | ExtName FAST_STRING (Maybe FAST_STRING)
411 isDynamic :: ExtName -> Bool
412 isDynamic Dynamic = True
416 instance Outputable ExtName where
417 ppr Dynamic = ptext SLIT("dynamic")
418 ppr (ExtName nm mb_mod) =
419 case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+>
420 doubleQuotes (ptext nm)
424 %************************************************************************
426 \subsection{Signatures in interface files}
428 %************************************************************************
437 instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
438 ppr (IfaceSig var ty _ _)
439 = hang (hsep [ppr var, dcolon])
444 | HsStrictness (HsStrictnessInfo name)
445 | HsUnfold InlinePragInfo (Maybe (UfExpr name))
446 | HsUpdate UpdateInfo
447 | HsSpecialise [HsTyVar name] [HsType name] (UfExpr name)
451 data HsStrictnessInfo name
452 = HsStrictnessInfo ([Demand], Bool)
453 (Maybe (name, [name])) -- Worker, if any
454 -- and needed constructors