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 (..) )
95 %************************************************************************
97 \subsection{Type synonyms}
99 %************************************************************************
102 type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
103 type RdrNameBangType = BangType RdrName
104 type RdrNameClassOpSig = Sig RdrName
105 type RdrNameConDecl = ConDecl RdrName
106 type RdrNameConDetails = ConDetails RdrName
107 type RdrNameContext = HsContext RdrName
108 type RdrNameHsDecl = HsDecl RdrName RdrNamePat
109 type RdrNameSpecDataSig = SpecDataSig RdrName
110 type RdrNameDefaultDecl = DefaultDecl RdrName
111 type RdrNameForeignDecl = ForeignDecl RdrName
112 type RdrNameGRHS = GRHS RdrName RdrNamePat
113 type RdrNameGRHSs = GRHSs RdrName RdrNamePat
114 type RdrNameHsBinds = HsBinds RdrName RdrNamePat
115 type RdrNameHsExpr = HsExpr RdrName RdrNamePat
116 type RdrNameHsModule = HsModule RdrName RdrNamePat
117 type RdrNameIE = IE RdrName
118 type RdrNameImportDecl = ImportDecl RdrName
119 type RdrNameInstDecl = InstDecl RdrName RdrNamePat
120 type RdrNameMatch = Match RdrName RdrNamePat
121 type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
122 type RdrNamePat = InPat RdrName
123 type RdrNameHsType = HsType RdrName
124 type RdrNameHsTyVar = HsTyVarBndr RdrName
125 type RdrNameSig = Sig RdrName
126 type RdrNameStmt = Stmt RdrName RdrNamePat
127 type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
128 type RdrNameRuleBndr = RuleBndr RdrName
129 type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
130 type RdrNameDeprecation = DeprecDecl RdrName
131 type RdrNameFixitySig = FixitySig RdrName
133 type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
135 type RdrNameClassOpPragmas = ClassOpPragmas RdrName
136 type RdrNameClassPragmas = ClassPragmas RdrName
137 type RdrNameDataPragmas = DataPragmas RdrName
138 type RdrNameGenPragmas = GenPragmas RdrName
139 type RdrNameInstancePragmas = InstancePragmas RdrName
143 %************************************************************************
145 \subsection{A few functions over HsSyn at RdrName}
147 %************************************************************************
149 @extractHsTyRdrNames@ finds the free variables of a HsType
150 It's used when making the for-alls explicit.
153 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
154 extractHsTyRdrNames ty = nub (extract_ty ty [])
156 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
157 extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
159 extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName]
160 extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys))
162 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
163 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
165 go (RuleBndr _) acc = acc
166 go (RuleBndrSig _ ty) acc = extract_ty ty acc
168 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
169 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
170 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
171 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
173 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
175 extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys
176 extract_pred (HsPIParam n ty) acc = extract_ty ty acc
178 extract_tys tys = foldr extract_ty [] tys
180 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
181 extract_ty (HsListTy ty) acc = extract_ty ty acc
182 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
183 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
184 extract_ty (HsPredTy p) acc = extract_pred p acc
185 extract_ty (HsUsgTy usg ty) acc = extract_ty ty acc
186 extract_ty (HsUsgForAllTy uv ty) acc = extract_ty ty acc
187 extract_ty (HsTyVar tv) acc = tv : acc
188 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
190 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
191 extract_ty (HsNumTy num) acc = acc
193 extract_ty (HsForAllTy (Just tvs) ctxt ty)
195 (filter (`notElem` locals) $
196 extract_ctxt ctxt (extract_ty ty []))
198 locals = hsTyVarNames tvs
201 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
202 extractPatsTyVars = filter isRdrTyVar .
205 collectSigTysFromPats
207 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
208 -- Get the type variables out of the type patterns in a bunch of
209 -- possibly-generic bindings in a class declaration
210 extractGenericPatTyVars binds
211 = filter isRdrTyVar (nub (get binds []))
213 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
214 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
217 get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
218 get_m other acc = acc
222 %************************************************************************
224 \subsection{Construction functions for Rdr stuff}
226 %************************************************************************
228 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
229 by deriving them from the name of the class. We fill in the names for the
230 tycon and datacon corresponding to the class, by deriving them from the
231 name of the class itself. This saves recording the names in the interface
232 file (which would be equally good).
234 Similarly for mkConDecl, mkClassOpSig and default-method names.
237 mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
238 = ClassDecl cxt cname tyvars fds sigs mbinds prags new_names loc
240 cls_occ = rdrNameOcc cname
241 data_occ = mkClassDataConOcc cls_occ
242 dname = mkRdrUnqual data_occ
243 dwname = mkRdrUnqual (mkWorkerOcc data_occ)
244 tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
245 sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
246 | n <- [1..length cxt]]
247 -- We number off the superclass selectors, 1, 2, 3 etc so that we
248 -- can construct names for the selectors. Thus
249 -- class (C a, C b) => D a b where ...
250 -- gives superclass selectors
252 -- (We used to call them D_C, but now we can have two different
253 -- superclasses both called C!)
254 new_names = toClassDeclNameList (tname, dname, dwname, sc_sel_names)
257 mkTyData new_or_data context tname list_var list_con i maybe pragmas src =
258 let t_occ = rdrNameOcc tname
259 name1 = mkRdrUnqual (mkGenOcc1 t_occ)
260 name2 = mkRdrUnqual (mkGenOcc2 t_occ)
261 in TyData new_or_data context
262 tname list_var list_con i maybe pragmas src name1 name2
264 mkClassOpSig (DefMeth x) op ty loc
265 = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
267 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
268 mkClassOpSig x op ty loc =
269 ClassOpSig op (Just x) ty loc
271 mkConDecl cname ex_vars cxt details loc
272 = ConDecl cname wkr_name ex_vars cxt details loc
274 wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
278 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
279 -- If the type checker sees (negate 3#) it will barf, because negate
280 -- can't take an unboxed arg. But that is exactly what it will see when
281 -- we write "-3#". So we have to do the negation right now!
283 -- We also do the same service for boxed literals, because this function
284 -- is also used for patterns (which, remember, are parsed as expressions)
285 -- and pattern don't have negation in them.
287 -- Finally, it's important to represent minBound as minBound, and not
288 -- as (negate (-minBound)), becuase the latter is out of range.
290 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
291 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
292 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
294 mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n)
295 mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
297 mkHsNegApp expr = NegApp expr (prelQual varName SLIT("negate"))
301 mkHsIntegralLit :: Integer -> HsOverLit RdrName
302 mkHsIntegralLit i = HsIntegral i (prelQual varName SLIT("fromInteger"))
304 mkHsFractionalLit :: Rational -> HsOverLit RdrName
305 mkHsFractionalLit f = HsFractional f (prelQual varName SLIT("fromRational"))
307 mkNPlusKPatIn :: RdrName -> HsOverLit RdrName -> RdrNamePat
308 mkNPlusKPatIn n k = NPlusKPatIn n k (prelQual varName SLIT("-"))
311 A useful function for building @OpApps@. The operator is always a
312 variable, and we don't know the fixity yet.
315 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
319 -----------------------------------------------------------------------------
321 -- Qualified Prelude names are always in scope; so we can just say Prelude.[]
322 -- for the list type constructor, say. But it's not so easy when we say
323 -- -fno-implicit-prelude. Then you just get whatever "[]" happens to be in scope.
325 unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
326 tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName
327 ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName
329 unitCon_RDR = prelQual dataName SLIT("()")
330 unitTyCon_RDR = prelQual tcName SLIT("()")
331 nilCon_RDR = prelQual dataName SLIT("[]")
332 listTyCon_RDR = prelQual tcName SLIT("[]")
333 funTyCon_RDR = prelQual tcName SLIT("(->)")
334 tupleCon_RDR arity = prelQual dataName (snd (mkTupNameStr Boxed arity))
335 tupleTyCon_RDR arity = prelQual tcName (snd (mkTupNameStr Boxed arity))
336 ubxTupleCon_RDR arity = prelQual dataName (snd (mkTupNameStr Unboxed arity))
337 ubxTupleTyCon_RDR arity = prelQual tcName (snd (mkTupNameStr Unboxed arity))
339 prelQual ns occ | opt_NoImplicitPrelude = mkUnqual ns occ
340 | otherwise = mkPreludeQual ns pRELUDE_Name occ
343 %************************************************************************
345 \subsection[rdrBinding]{Bindings straight out of the parser}
347 %************************************************************************
351 = -- On input we use the Empty/And form rather than a list
353 | RdrAndBindings RdrBinding RdrBinding
355 -- Value bindings havn't been united with their
357 | RdrValBinding RdrNameMonoBinds
359 -- Signatures are mysterious; we can't
360 -- tell if its a Sig or a ClassOpSig,
361 -- so we just save the pieces:
364 -- The remainder all fit into the main HsDecl form
365 | RdrHsDecl RdrNameHsDecl
367 type SigConverter = RdrNameSig -> RdrNameSig
374 (Maybe RdrNameHsType)
378 %************************************************************************
380 \subsection[cvDecls]{Convert various top-level declarations}
382 %************************************************************************
384 We make a point not to throw any user-pragma ``sigs'' at
385 these conversion functions:
388 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
392 cvInstDeclSig sig = sig
394 cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
395 cvClassOpSig sig = sig
399 %************************************************************************
401 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
403 %************************************************************************
405 Function definitions are restructured here. Each is assumed to be recursive
406 initially, and non recursive definitions are discovered by the dependency
410 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
411 -- The mysterious SigConverter converts Sigs to ClassOpSigs
412 -- in class declarations. Mostly it's just an identity function
414 cvBinds sig_cvtr binding
415 = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
416 MonoBind mbs sigs Recursive
421 cvMonoBindsAndSigs :: SigConverter
423 -> (RdrNameMonoBinds, [RdrNameSig])
425 cvMonoBindsAndSigs sig_cvtr fb
426 = mangle_bind (EmptyMonoBinds, []) fb
428 mangle_bind acc RdrNullBind
431 mangle_bind acc (RdrAndBindings fb1 fb2)
432 = mangle_bind (mangle_bind acc fb1) fb2
434 mangle_bind (b_acc, s_acc) (RdrSig sig)
435 = (b_acc, sig_cvtr sig : s_acc)
437 mangle_bind (b_acc, s_acc) (RdrValBinding binding)
438 = (b_acc `AndMonoBinds` binding, s_acc)
442 %************************************************************************
444 \subsection[PrefixToHS-utils]{Utilities for conversion}
446 %************************************************************************
448 Separate declarations into all the various kinds:
451 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
454 (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
456 (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
458 go acc RdrNullBind = acc
459 go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
460 go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
461 go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
462 go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
463 go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)