2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
6 (Well, really, for specialisations involving @RdrName@s, even if
7 they are used somewhat later on in the compiler...)
47 RdrNameClassOpPragmas,
51 RdrNameInstancePragmas,
53 extractHsTyRdrTyVars, extractHsTysRdrTyVars,
55 extractRuleBndrsTyVars,
56 extractHsCtxtRdrTyVars, extractGenericPatTyVars,
58 mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
59 mkHsNegApp, mkHsIntegralLit, mkHsFractionalLit, mkNPlusKPatIn,
62 -- some built-in names (all :: RdrName)
63 unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR,
64 tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR,
70 cvValSig, cvClassOpSig, cvInstDeclSig,
74 #include "HsVersions.h"
76 import HsSyn -- Lots of it
77 import CmdLineOpts ( opt_NoImplicitPrelude )
78 import HsPat ( collectSigTysFromPats )
79 import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
80 mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
81 mkGenOcc2, varName, dataName, tcName
83 import PrelNames ( pRELUDE_Name, mkTupNameStr )
84 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
85 mkUnqual, mkPreludeQual
89 import BasicTypes ( Boxity(..), RecFlag(..) )
90 import Class ( DefMeth (..) )
94 %************************************************************************
96 \subsection{Type synonyms}
98 %************************************************************************
101 type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
102 type RdrNameBangType = BangType RdrName
103 type RdrNameClassOpSig = Sig RdrName
104 type RdrNameConDecl = ConDecl RdrName
105 type RdrNameConDetails = ConDetails RdrName
106 type RdrNameContext = HsContext RdrName
107 type RdrNameHsDecl = HsDecl RdrName RdrNamePat
108 type RdrNameSpecDataSig = SpecDataSig RdrName
109 type RdrNameDefaultDecl = DefaultDecl RdrName
110 type RdrNameForeignDecl = ForeignDecl RdrName
111 type RdrNameGRHS = GRHS RdrName RdrNamePat
112 type RdrNameGRHSs = GRHSs RdrName RdrNamePat
113 type RdrNameHsBinds = HsBinds RdrName RdrNamePat
114 type RdrNameHsExpr = HsExpr RdrName RdrNamePat
115 type RdrNameHsModule = HsModule RdrName RdrNamePat
116 type RdrNameIE = IE RdrName
117 type RdrNameImportDecl = ImportDecl RdrName
118 type RdrNameInstDecl = InstDecl RdrName RdrNamePat
119 type RdrNameMatch = Match RdrName RdrNamePat
120 type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
121 type RdrNamePat = InPat RdrName
122 type RdrNameHsType = HsType RdrName
123 type RdrNameHsTyVar = HsTyVarBndr RdrName
124 type RdrNameSig = Sig RdrName
125 type RdrNameStmt = Stmt RdrName RdrNamePat
126 type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
127 type RdrNameRuleBndr = RuleBndr RdrName
128 type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
129 type RdrNameDeprecation = DeprecDecl RdrName
130 type RdrNameFixitySig = FixitySig RdrName
132 type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
134 type RdrNameClassOpPragmas = ClassOpPragmas RdrName
135 type RdrNameClassPragmas = ClassPragmas RdrName
136 type RdrNameDataPragmas = DataPragmas RdrName
137 type RdrNameGenPragmas = GenPragmas RdrName
138 type RdrNameInstancePragmas = InstancePragmas RdrName
142 %************************************************************************
144 \subsection{A few functions over HsSyn at RdrName}
146 %************************************************************************
148 @extractHsTyRdrNames@ finds the free variables of a HsType
149 It's used when making the for-alls explicit.
152 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
153 extractHsTyRdrNames ty = nub (extract_ty ty [])
155 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
156 extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
158 extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName]
159 extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys))
161 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
162 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
164 go (RuleBndr _) acc = acc
165 go (RuleBndrSig _ ty) acc = extract_ty ty acc
167 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
168 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
169 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
170 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
172 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
174 extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys
175 extract_pred (HsPIParam n ty) acc = extract_ty ty acc
177 extract_tys tys = foldr extract_ty [] tys
179 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
180 extract_ty (HsListTy ty) acc = extract_ty ty acc
181 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
182 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
183 extract_ty (HsPredTy p) acc = extract_pred p acc
184 extract_ty (HsUsgTy usg ty) acc = extract_ty ty acc
185 extract_ty (HsUsgForAllTy uv ty) acc = extract_ty ty acc
186 extract_ty (HsTyVar tv) acc = tv : acc
187 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
189 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
190 extract_ty (HsNumTy num) acc = acc
192 extract_ty (HsForAllTy (Just tvs) ctxt ty)
194 (filter (`notElem` locals) $
195 extract_ctxt ctxt (extract_ty ty []))
197 locals = hsTyVarNames tvs
200 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
201 extractPatsTyVars = filter isRdrTyVar .
204 collectSigTysFromPats
206 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
207 -- Get the type variables out of the type patterns in a bunch of
208 -- possibly-generic bindings in a class declaration
209 extractGenericPatTyVars binds
210 = filter isRdrTyVar (nub (get binds []))
212 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
213 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
216 get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
217 get_m other acc = acc
221 %************************************************************************
223 \subsection{Construction functions for Rdr stuff}
225 %************************************************************************
227 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
228 by deriving them from the name of the class. We fill in the names for the
229 tycon and datacon corresponding to the class, by deriving them from the
230 name of the class itself. This saves recording the names in the interface
231 file (which would be equally good).
233 Similarly for mkConDecl, mkClassOpSig and default-method names.
236 mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
237 = ClassDecl cxt cname tyvars fds sigs mbinds prags new_names loc
239 cls_occ = rdrNameOcc cname
240 data_occ = mkClassDataConOcc cls_occ
241 dname = mkRdrUnqual data_occ
242 dwname = mkRdrUnqual (mkWorkerOcc data_occ)
243 tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
244 sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
245 | n <- [1..length cxt]]
246 -- We number off the superclass selectors, 1, 2, 3 etc so that we
247 -- can construct names for the selectors. Thus
248 -- class (C a, C b) => D a b where ...
249 -- gives superclass selectors
251 -- (We used to call them D_C, but now we can have two different
252 -- superclasses both called C!)
253 new_names = toClassDeclNameList (tname, dname, dwname, sc_sel_names)
256 mkTyData new_or_data context tname list_var list_con i maybe pragmas src =
257 let t_occ = rdrNameOcc tname
258 name1 = mkRdrUnqual (mkGenOcc1 t_occ)
259 name2 = mkRdrUnqual (mkGenOcc2 t_occ)
260 in TyData new_or_data context
261 tname list_var list_con i maybe pragmas src name1 name2
263 mkClassOpSig (DefMeth x) op ty loc
264 = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
266 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
267 mkClassOpSig x op ty loc =
268 ClassOpSig op (Just x) ty loc
270 mkConDecl cname ex_vars cxt details loc
271 = ConDecl cname wkr_name ex_vars cxt details loc
273 wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
277 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
278 -- If the type checker sees (negate 3#) it will barf, because negate
279 -- can't take an unboxed arg. But that is exactly what it will see when
280 -- we write "-3#". So we have to do the negation right now!
282 -- We also do the same service for boxed literals, because this function
283 -- is also used for patterns (which, remember, are parsed as expressions)
284 -- and pattern don't have negation in them.
286 -- Finally, it's important to represent minBound as minBound, and not
287 -- as (negate (-minBound)), becuase the latter is out of range.
289 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
290 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
291 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
293 mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n)
294 mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
296 mkHsNegApp expr = NegApp expr (prelQual varName SLIT("negate"))
300 mkHsIntegralLit :: Integer -> HsOverLit RdrName
301 mkHsIntegralLit i = HsIntegral i (prelQual varName SLIT("fromInteger"))
303 mkHsFractionalLit :: Rational -> HsOverLit RdrName
304 mkHsFractionalLit f = HsFractional f (prelQual varName SLIT("fromRational"))
306 mkNPlusKPatIn :: RdrName -> HsOverLit RdrName -> RdrNamePat
307 mkNPlusKPatIn n k = NPlusKPatIn n k (prelQual varName SLIT("-"))
310 A useful function for building @OpApps@. The operator is always a
311 variable, and we don't know the fixity yet.
314 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
318 -----------------------------------------------------------------------------
320 -- Qualified Prelude names are always in scope; so we can just say Prelude.[]
321 -- for the list type constructor, say. But it's not so easy when we say
322 -- -fno-implicit-prelude. Then you just get whatever "[]" happens to be in scope.
324 unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
325 tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName
326 ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName
328 unitCon_RDR = prelQual dataName SLIT("()")
329 unitTyCon_RDR = prelQual tcName SLIT("()")
330 nilCon_RDR = prelQual dataName SLIT("[]")
331 listTyCon_RDR = prelQual tcName SLIT("[]")
332 funTyCon_RDR = prelQual tcName SLIT("(->)")
333 tupleCon_RDR arity = prelQual dataName (snd (mkTupNameStr Boxed arity))
334 tupleTyCon_RDR arity = prelQual tcName (snd (mkTupNameStr Boxed arity))
335 ubxTupleCon_RDR arity = prelQual dataName (snd (mkTupNameStr Unboxed arity))
336 ubxTupleTyCon_RDR arity = prelQual tcName (snd (mkTupNameStr Unboxed arity))
338 prelQual ns occ | opt_NoImplicitPrelude = mkUnqual ns occ
339 | otherwise = mkPreludeQual ns pRELUDE_Name occ
342 %************************************************************************
344 \subsection[rdrBinding]{Bindings straight out of the parser}
346 %************************************************************************
350 = -- On input we use the Empty/And form rather than a list
352 | RdrAndBindings RdrBinding RdrBinding
354 -- Value bindings havn't been united with their
356 | RdrValBinding RdrNameMonoBinds
358 -- Signatures are mysterious; we can't
359 -- tell if its a Sig or a ClassOpSig,
360 -- so we just save the pieces:
363 -- The remainder all fit into the main HsDecl form
364 | RdrHsDecl RdrNameHsDecl
366 type SigConverter = RdrNameSig -> RdrNameSig
373 (Maybe RdrNameHsType)
377 %************************************************************************
379 \subsection[cvDecls]{Convert various top-level declarations}
381 %************************************************************************
383 We make a point not to throw any user-pragma ``sigs'' at
384 these conversion functions:
387 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
391 cvInstDeclSig sig = sig
393 cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
394 cvClassOpSig sig = sig
398 %************************************************************************
400 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
402 %************************************************************************
404 Function definitions are restructured here. Each is assumed to be recursive
405 initially, and non recursive definitions are discovered by the dependency
409 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
410 -- The mysterious SigConverter converts Sigs to ClassOpSigs
411 -- in class declarations. Mostly it's just an identity function
413 cvBinds sig_cvtr binding
414 = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
415 MonoBind mbs sigs Recursive
420 cvMonoBindsAndSigs :: SigConverter
422 -> (RdrNameMonoBinds, [RdrNameSig])
424 cvMonoBindsAndSigs sig_cvtr fb
425 = mangle_bind (EmptyMonoBinds, []) fb
427 mangle_bind acc RdrNullBind
430 mangle_bind acc (RdrAndBindings fb1 fb2)
431 = mangle_bind (mangle_bind acc fb1) fb2
433 mangle_bind (b_acc, s_acc) (RdrSig sig)
434 = (b_acc, sig_cvtr sig : s_acc)
436 mangle_bind (b_acc, s_acc) (RdrValBinding binding)
437 = (b_acc `AndMonoBinds` binding, s_acc)
441 %************************************************************************
443 \subsection[PrefixToHS-utils]{Utilities for conversion}
445 %************************************************************************
447 Separate declarations into all the various kinds:
450 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
453 (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
455 (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
457 go acc RdrNullBind = acc
458 go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
459 go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
460 go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
461 go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
462 go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)