X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnHsSyn.lhs;h=b958f9d61cb871171988668c1ef9fee0afaf59fe;hp=7d2282b2875f501ab1baaa7d4e4f0edce8a61aa2;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=fdbcd37e95784cc5d0392fc2962a3158fd440fe4 diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 7d2282b..b958f9d 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -4,13 +4,6 @@ \section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module RnHsSyn( -- Names charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name, @@ -18,16 +11,14 @@ module RnHsSyn( extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames, -- Free variables - hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs, - - maybeGenericMatch + hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs ) where #include "HsVersions.h" import HsSyn import Class ( FunDep ) -import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) +import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, hetMetCodeTypeTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) @@ -47,6 +38,8 @@ charTyCon_name, listTyCon_name, parrTyCon_name :: Name charTyCon_name = getName charTyCon listTyCon_name = getName listTyCon parrTyCon_name = getName parrTyCon +hetMetCodeTypeTyCon_name :: Name +hetMetCodeTypeTyCon_name = getName hetMetCodeTypeTyCon tupleTyCon_name :: Boxity -> Int -> Name tupleTyCon_name boxity n = getName (tupleTyCon boxity n) @@ -66,22 +59,26 @@ extractHsTyNames ty get (HsAppTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` getl ty get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty - get (HsTupleTy con tys) = extractHsTyNames_s tys + get (HsModalBoxType ecn ty) = (unitNameSet ecn) `unionNameSets` (unitNameSet hetMetCodeTypeTyCon_name) `unionNameSets` (getl ty) + get (HsTupleTy _ tys) = extractHsTyNames_s tys get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 get (HsPredTy p) = extractHsPredTyNames p get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) get (HsParTy ty) = getl ty get (HsBangTy _ ty) = getl ty - get (HsNumTy n) = emptyNameSet + get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds) get (HsTyVar tv) = unitNameSet tv - get (HsSpliceTy _) = emptyNameSet -- Type splices mention no type variables - get (HsKindSig ty k) = getl ty + get (HsSpliceTy _ fvs _) = fvs + get (HsQuasiQuoteTy {}) = emptyNameSet + get (HsKindSig ty _) = getl ty get (HsForAllTy _ tvs ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` getl ty) `minusNameSet` mkNameSet (hsLTyVarNames tvs) get (HsDocTy ty _) = getl ty + get (HsCoreTy {}) = emptyNameSet -- This probably isn't quite right + -- but I don't think it matters extractHsTyNames_s :: [LHsType Name] -> NameSet extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys @@ -92,11 +89,12 @@ extractHsCtxtTyNames (L _ ctxt) -- You don't import or export implicit parameters, -- so don't mention the IP names +extractHsPredTyNames :: HsPred Name -> NameSet extractHsPredTyNames (HsClassP cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys extractHsPredTyNames (HsEqualP ty1 ty2) = extractHsTyNames ty1 `unionNameSets` extractHsTyNames ty2 -extractHsPredTyNames (HsIParam n ty) +extractHsPredTyNames (HsIParam _ ty) = extractHsTyNames ty \end{code} @@ -121,12 +119,15 @@ In all cases this is set up for interface-file declarations: hsSigsFVs :: [LSig Name] -> FreeVars hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) -hsSigFVs (TypeSig v ty) = extractHsTyNames ty -hsSigFVs (SpecInstSig ty) = extractHsTyNames ty -hsSigFVs (SpecSig v ty inl) = extractHsTyNames ty -hsSigFVs other = emptyFVs +hsSigFVs :: Sig Name -> FreeVars +hsSigFVs (TypeSig _ ty) = extractHsTyNames ty +hsSigFVs (GenericSig _ ty) = extractHsTyNames ty +hsSigFVs (SpecInstSig ty) = extractHsTyNames ty +hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty +hsSigFVs _ = emptyFVs ---------------- +conDeclFVs :: LConDecl Name -> FreeVars conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context, con_details = details, con_res = res_ty})) = delFVs (map hsLTyVarName tyvars) $ @@ -134,32 +135,13 @@ conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context, conDetailsFVs details `plusFV` conResTyFVs res_ty +conResTyFVs :: ResType Name -> FreeVars conResTyFVs ResTyH98 = emptyFVs conResTyFVs (ResTyGADT ty) = extractHsTyNames ty conDetailsFVs :: HsConDeclDetails Name -> FreeVars conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details)) +bangTyFVs :: LHsType Name -> FreeVars bangTyFVs bty = extractHsTyNames (getBangType bty) \end{code} - - -%************************************************************************ -%* * -\subsection{A few functions on generic defintions -%* * -%************************************************************************ - -These functions on generics are defined over Matches Name, which is -why they are here and not in HsMatches. - -\begin{code} -maybeGenericMatch :: LMatch Name -> Maybe (HsType Name, LMatch Name) - -- Tells whether a Match is for a generic definition - -- and extract the type from a generic match and put it at the front - -maybeGenericMatch (L loc (Match (L _ (TypePat (L _ ty)) : pats) sig_ty grhss)) - = Just (ty, L loc (Match pats sig_ty grhss)) - -maybeGenericMatch other_match = Nothing -\end{code}