2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[HsDecls]{Abstract syntax: global declarations}
6 Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
7 @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
12 #include "HsVersions.h"
15 import HsBinds ( HsBinds, MonoBinds, Sig, nullMonoBinds )
16 import HsPragmas ( DataPragmas, ClassPragmas )
18 import HsCore ( UfExpr )
19 import BasicTypes ( Fixity, NewOrData(..) )
20 import IdInfo ( ArgUsageInfo, FBTypeInfo, ArityInfo, UpdateInfo )
21 import Demand ( Demand )
22 import CallConv ( CallConv, pprCallConv )
25 import Name ( getOccName, OccName, NamedThing(..) )
27 import SrcLoc ( SrcLoc )
32 %************************************************************************
34 \subsection[HsDecl]{Declarations}
36 %************************************************************************
39 data HsDecl flexi name pat
41 | ClD (ClassDecl flexi name pat)
42 | InstD (InstDecl flexi name pat)
43 | DefD (DefaultDecl name)
44 | ValD (HsBinds flexi name pat)
45 | SigD (IfaceSig name)
46 | ForD (ForeignDecl name)
51 hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
52 => HsDecl flexi name pat -> name
54 hsDeclName (TyD (TyData _ _ name _ _ _ _ _)) = name
55 hsDeclName (TyD (TySynonym name _ _ _)) = name
56 hsDeclName (ClD (ClassDecl _ name _ _ _ _ _ _ _)) = name
57 hsDeclName (SigD (IfaceSig name _ _ _)) = name
58 hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
59 hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
60 -- Others don't make sense
62 hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
67 instance (NamedThing name, Outputable name, Outputable pat)
68 => Outputable (HsDecl flexi name pat) where
72 ppr (SigD sig) = ppr sig
73 ppr (ValD binds) = ppr binds
74 ppr (DefD def) = ppr def
75 ppr (InstD inst) = ppr inst
76 ppr (ForD fd) = ppr fd
79 -- hsDeclName needs more context when DEBUG is on
80 instance (NamedThing name, Outputable name, Outputable pat, Eq name)
81 => Eq (HsDecl flex name pat) where
82 d1 == d2 = hsDeclName d1 == hsDeclName d2
84 instance (NamedThing name, Outputable name, Outputable pat, Ord name)
85 => Ord (HsDecl flex name pat) where
86 d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
88 instance (Eq name) => Eq (HsDecl flex name pat) where
89 d1 == d2 = hsDeclName d1 == hsDeclName d2
91 instance (Ord name) => Ord (HsDecl flexi name pat) where
92 d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
97 %************************************************************************
99 \subsection[FixityDecl]{A fixity declaration}
101 %************************************************************************
104 data FixityDecl name = FixityDecl name Fixity SrcLoc
106 instance Outputable name => Outputable (FixityDecl name) where
107 ppr (FixityDecl name fixity loc) = sep [ppr fixity, ppr name]
111 %************************************************************************
113 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
115 %************************************************************************
120 (Context name) -- context
121 name -- type constructor
122 [HsTyVar name] -- type variables
123 [ConDecl name] -- data constructors (empty if abstract)
124 (Maybe [name]) -- derivings; Nothing => not specified
125 -- (i.e., derive default); Just [] => derive
126 -- *nothing*; Just <list> => as you would
131 | TySynonym name -- type constructor
132 [HsTyVar name] -- type variables
133 (HsType name) -- synonym expansion
139 instance (NamedThing name, Outputable name)
140 => Outputable (TyDecl name) where
142 ppr (TySynonym tycon tyvars mono_ty src_loc)
143 = hang (pp_decl_head SLIT("type") empty tycon tyvars)
146 ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
148 (pp_decl_head keyword (pp_context_and_arrow context) tycon tyvars)
149 (pp_condecls condecls)
152 keyword = case new_or_data of
153 NewType -> SLIT("newtype")
154 DataType -> SLIT("data")
156 pp_decl_head str pp_context tycon tyvars
157 = hsep [ptext str, pp_context, ppr tycon,
158 interppSP tyvars, ptext SLIT("=")]
160 pp_condecls [] = empty -- Curious!
162 = sep (ppr c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr c)) cs)
164 pp_tydecl pp_head pp_decl_rhs derivings
165 = hang pp_head 4 (sep [
169 Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
172 pp_context_and_arrow :: Outputable name => Context name -> SDoc
173 pp_context_and_arrow [] = empty
174 pp_context_and_arrow theta = hsep [pprContext theta, ptext SLIT("=>")]
177 A type for recording what types a datatype should be specialised to.
178 It's called a ``Sig'' because it's sort of like a ``type signature''
179 for an datatype declaration.
182 data SpecDataSig name
183 = SpecDataSig name -- tycon to specialise
187 instance (NamedThing name, Outputable name)
188 => Outputable (SpecDataSig name) where
190 ppr (SpecDataSig tycon ty _)
191 = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
194 %************************************************************************
196 \subsection[ConDecl]{A data-constructor declaration}
198 %************************************************************************
202 = ConDecl name -- Constructor name
203 (Context name) -- Existential context for this constructor
208 = VanillaCon -- prefix-style con decl
211 | InfixCon -- infix-style con decl
215 | RecCon -- record-style con decl
216 [([name], BangType name)] -- list of "fields"
218 | NewCon -- newtype con decl
222 = Banged (HsType name) -- HsType: to allow Haskell extensions
223 | Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
227 instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
228 ppr (ConDecl con cxt con_details loc)
229 = pp_context_and_arrow cxt <+> ppr_con_details con con_details
231 ppr_con_details con (InfixCon ty1 ty2)
232 = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
234 ppr_con_details con (VanillaCon tys)
235 = ppr con <+> hsep (map (ppr_bang) tys)
237 ppr_con_details con (NewCon ty)
238 = ppr con <+> pprParendHsType ty
240 ppr_con_details con (RecCon fields)
241 = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
243 ppr_field (ns, ty) = hsep (map (ppr) ns) <+>
247 ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty
248 ppr_bang (Unbanged ty) = pprParendHsType ty
251 %************************************************************************
253 \subsection[ClassDecl]{A class declaration}
255 %************************************************************************
258 data ClassDecl flexi name pat
259 = ClassDecl (Context name) -- context...
260 name -- name of the class
261 [HsTyVar name] -- the class type variables
262 [Sig name] -- methods' signatures
263 (MonoBinds flexi name pat) -- default methods
265 name name -- The names of the tycon and datacon for this class
266 -- These are filled in by the renamer
271 instance (NamedThing name, Outputable name, Outputable pat)
272 => Outputable (ClassDecl flexi name pat) where
274 ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
275 | null sigs -- No "where" part
278 | otherwise -- Laid out
279 = sep [hsep [top_matter, ptext SLIT("where {")],
280 nest 4 (vcat [sep (map ppr_sig sigs),
284 top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow context,
285 ppr clas, hsep (map (ppr) tyvars)]
286 ppr_sig sig = ppr sig <> semi
289 %************************************************************************
291 \subsection[InstDecl]{An instance declaration
293 %************************************************************************
296 data InstDecl flexi name pat
297 = InstDecl (HsType name) -- Context => Class Instance-type
298 -- Using a polytype means that the renamer conveniently
299 -- figures out the quantified type variables for us.
301 (MonoBinds flexi name pat)
303 [Sig name] -- User-supplied pragmatic info
305 (Maybe name) -- Name for the dictionary function
311 instance (NamedThing name, Outputable name, Outputable pat)
312 => Outputable (InstDecl flexi name pat) where
314 ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
315 = getPprStyle $ \ sty ->
316 if ifaceStyle sty || (nullMonoBinds binds && null uprags) then
317 hsep [ptext SLIT("instance"), ppr inst_ty]
319 vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
325 %************************************************************************
327 \subsection[DefaultDecl]{A @default@ declaration}
329 %************************************************************************
331 There can only be one default declaration per module, but it is hard
332 for the parser to check that; we pass them all through in the abstract
333 syntax, and that restriction must be checked in the front end.
336 data DefaultDecl name
337 = DefaultDecl [HsType name]
340 instance (NamedThing name, Outputable name)
341 => Outputable (DefaultDecl name) where
343 ppr (DefaultDecl tys src_loc)
344 = ptext SLIT("default") <+> parens (interpp'SP tys)
347 %************************************************************************
349 \subsection{Foreign function interface declaration}
351 %************************************************************************
354 data ForeignDecl name =
357 (Maybe Bool) -- Nothing => foreign export; Just unsafe => foreign import unsafe
363 instance (NamedThing name, Outputable name)
364 => Outputable (ForeignDecl name) where
366 ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
367 = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+>
368 ppr ext_name <+> ppr_unsafe <+> ppr nm <+> ptext SLIT("::") <+> ppr ty
370 (ppr_imp_exp, ppr_unsafe) =
372 Nothing -> (ptext SLIT("export"), empty)
373 Just us -> (ptext SLIT("import"), ptext SLIT("unsafe"))
377 | ExtName FAST_STRING (Maybe FAST_STRING)
379 isDynamic :: ExtName -> Bool
380 isDynamic Dynamic = True
384 instance Outputable ExtName where
385 ppr Dynamic = ptext SLIT("dynamic")
386 ppr (ExtName nm mb_mod) =
387 case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+>
388 doubleQuotes (ptext nm)
392 %************************************************************************
394 \subsection{Signatures in interface files}
396 %************************************************************************
405 instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
406 ppr (IfaceSig var ty _ _)
407 = hang (hsep [ppr var, ptext SLIT("::")])
412 | HsStrictness (HsStrictnessInfo name)
413 | HsUnfold Bool (UfExpr name) -- True <=> INLINE pragma
414 | HsUpdate UpdateInfo
415 | HsArgUsage ArgUsageInfo
416 | HsFBType FBTypeInfo
417 | HsSpecialise [HsTyVar name] [HsType name] (UfExpr name)
420 data HsStrictnessInfo name
421 = HsStrictnessInfo [Demand]
422 (Maybe (name, [name])) -- Worker, if any
423 -- and needed constructors