RdrMatch(..),
SigConverter,
- extractHsTyRdrNames,
- extractHsTyRdrTyVars, extractHsTysRdrTyVars,
- extractPatsTyVars,
- extractRuleBndrsTyVars,
+ extractHsTyRdrNames, extractHsTyRdrTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
- mkHsNegApp,
+ mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
+ mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
+ mkHsDo,
cvBinds,
cvMonoBindsAndSigs,
#include "HsVersions.h"
import HsSyn -- Lots of it
-import HsPat ( collectSigTysFromPats )
import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
- mkGenOcc2,
+ mkGenOcc2
)
-import PrelNames ( negate_RDR )
-import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
- )
+import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
import List ( nub )
import BasicTypes ( RecFlag(..) )
import Class ( DefMeth (..) )
It's used when making the for-alls explicit.
\begin{code}
-extractHsTyRdrNames :: HsType RdrName -> [RdrName]
+extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
extractHsTyRdrNames ty = nub (extract_ty ty [])
-extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
-extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
-
-extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName]
-extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys))
-
-extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
-extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
- where
- go (RuleBndr _) acc = acc
- go (RuleBndrSig _ ty) acc = extract_ty ty acc
+extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
+extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
extract_ctxt ctxt acc = foldr extract_pred acc ctxt
-extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys
-extract_pred (HsPIParam n ty) acc = extract_ty ty acc
+extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
+extract_pred (HsIParam n ty) acc = extract_ty ty acc
extract_tys tys = foldr extract_ty [] tys
extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (HsListTy ty) acc = extract_ty ty acc
+extract_ty (HsPArrTy ty) acc = extract_ty ty acc
extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (HsPredTy p) acc = extract_pred p acc
-extract_ty (HsUsgTy usg ty) acc = extract_ty ty acc
-extract_ty (HsUsgForAllTy uv ty) acc = extract_ty ty acc
extract_ty (HsTyVar tv) acc = tv : acc
-extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
+extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
+extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsParTy ty) acc = extract_ty ty acc
-- Generics
-extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (HsNumTy num) acc = acc
--- Generics
+extract_ty (HsKindSig ty k) acc = extract_ty ty acc
extract_ty (HsForAllTy (Just tvs) ctxt ty)
acc = acc ++
(filter (`notElem` locals) $
where
locals = hsTyVarNames tvs
-
-extractPatsTyVars :: [RdrNamePat] -> [RdrName]
-extractPatsTyVars = filter isRdrTyVar .
- nub .
- extract_tys .
- collectSigTysFromPats
-
extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
-- Get the type variables out of the type patterns in a bunch of
-- possibly-generic bindings in a class declaration
get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
get other acc = acc
- get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
- get_m other acc = acc
+ get_m (Match (TypePatIn ty : _) _ _) acc = extract_ty ty acc
+ get_m other acc = acc
\end{code}
file (which would be equally good).
Similarly for mkConDecl, mkClassOpSig and default-method names.
+
+ *** See "THE NAMING STORY" in HsDecls ****
\begin{code}
-mkClassDecl cxt cname tyvars fds sigs mbinds loc
- = ClassDecl cxt cname tyvars fds sigs mbinds new_names loc
+mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
+ = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
+ tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
+ tcdSysNames = new_names, tcdLoc = loc }
where
cls_occ = rdrNameOcc cname
data_occ = mkClassDataConOcc cls_occ
-- superclasses both called C!)
new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
--- mkTyData :: ??
-mkTyData new_or_data context tname list_var list_con i maybe src
+mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
= let t_occ = rdrNameOcc tname
name1 = mkRdrUnqual (mkGenOcc1 t_occ)
name2 = mkRdrUnqual (mkGenOcc2 t_occ)
- in TyData new_or_data context
- tname list_var list_con i maybe src name1 name2
+ in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
+ tcdTyVars = tyvars, tcdCons = data_cons,
+ tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
-mkClassOpSig (DefMeth x) op ty loc
- = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
+mkClassOpSigDM op ty loc
+ = ClassOpSig op (DefMeth dm_rn) ty loc
where
dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
-mkClassOpSig x op ty loc =
- ClassOpSig op (Just x) ty loc
mkConDecl cname ex_vars cxt details loc
= ConDecl cname wkr_name ex_vars cxt details loc
-- If the type checker sees (negate 3#) it will barf, because negate
-- can't take an unboxed arg. But that is exactly what it will see when
-- we write "-3#". So we have to do the negation right now!
---
--- We also do the same service for boxed literals, because this function
--- is also used for patterns (which, remember, are parsed as expressions)
--- and pattern don't have negation in them.
---
--- Finally, it's important to represent minBound as minBound, and not
--- as (negate (-minBound)), becuase the latter is out of range.
mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
-
-mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n)
-mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
-mkHsNegApp expr = NegApp expr negate_RDR
+mkHsNegApp expr = NegApp expr placeHolderName
\end{code}
A useful function for building @OpApps@. The operator is always a
mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
\end{code}
+These are the bits of syntax that contain rebindable names
+See RnEnv.lookupSyntaxName
+
+\begin{code}
+mkHsIntegral i = HsIntegral i placeHolderName
+mkHsFractional f = HsFractional f placeHolderName
+mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
+mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
+\end{code}
+
%************************************************************************
%* *
cvInstDeclSig sig = sig
-cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
+cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
cvClassOpSig sig = sig
\end{code}
projects / ghc-hetmet.git / blobdiff