RdrNameBangType,
RdrNameClassOpSig,
RdrNameConDecl,
+ RdrNameConDetails,
RdrNameContext,
- RdrNameSpecDataSig,
RdrNameDefaultDecl,
RdrNameForeignDecl,
RdrNameGRHS,
RdrNameTyClDecl,
RdrNameRuleDecl,
RdrNameRuleBndr,
+ RdrNameDeprecation,
RdrNameHsRecordBinds,
+ RdrNameFixitySig,
RdrBinding(..),
RdrMatch(..),
SigConverter,
- RdrNameClassOpPragmas,
- RdrNameClassPragmas,
- RdrNameDataPragmas,
- RdrNameGenPragmas,
- RdrNameInstancePragmas,
- extractHsTyRdrNames,
- extractPatsTyVars, extractRuleBndrsTyVars,
+ extractHsTyRdrNames, extractHsTyRdrTyVars,
+ extractHsCtxtRdrTyVars, extractGenericPatTyVars,
- mkOpApp, mkClassDecl, mkClassOpSig,
+ mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
+ mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
cvBinds,
cvMonoBindsAndSigs,
cvTopDecls,
- cvValSig, cvClassOpSig, cvInstDeclSig
+ cvValSig, cvClassOpSig, cvInstDeclSig,
+ mkTyData
) where
#include "HsVersions.h"
-import HsSyn
-import Name ( mkClassTyConOcc, mkClassDataConOcc )
-import OccName ( mkClassTyConOcc, mkClassDataConOcc,
- mkSuperDictSelOcc, mkDefaultMethodOcc
+import HsSyn -- Lots of it
+import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
+ mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
+ mkGenOcc2,
)
-import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
-import Util ( thenCmp )
-import HsPragmas
+import PrelNames ( minusName, negateName, fromIntegerName, fromRationalName )
+import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
import List ( nub )
import BasicTypes ( RecFlag(..) )
-import Outputable
+import Class ( DefMeth (..) )
\end{code}
type RdrNameBangType = BangType RdrName
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
-type RdrNameContext = Context RdrName
+type RdrNameConDetails = ConDetails RdrName
+type RdrNameContext = HsContext RdrName
type RdrNameHsDecl = HsDecl RdrName RdrNamePat
-type RdrNameSpecDataSig = SpecDataSig RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
type RdrNameForeignDecl = ForeignDecl RdrName
type RdrNameGRHS = GRHS RdrName RdrNamePat
type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
type RdrNamePat = InPat RdrName
type RdrNameHsType = HsType RdrName
-type RdrNameHsTyVar = HsTyVar RdrName
+type RdrNameHsTyVar = HsTyVarBndr RdrName
type RdrNameSig = Sig RdrName
type RdrNameStmt = Stmt RdrName RdrNamePat
type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
+
type RdrNameRuleBndr = RuleBndr RdrName
type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
+type RdrNameDeprecation = DeprecDecl RdrName
+type RdrNameFixitySig = FixitySig RdrName
type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
-
-type RdrNameClassOpPragmas = ClassOpPragmas RdrName
-type RdrNameClassPragmas = ClassPragmas RdrName
-type RdrNameDataPragmas = DataPragmas RdrName
-type RdrNameGenPragmas = GenPragmas RdrName
-type RdrNameInstancePragmas = InstancePragmas RdrName
\end{code}
It's used when making the for-alls explicit.
\begin{code}
-extractHsTyRdrNames :: HsType RdrName -> [RdrName]
+extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
extractHsTyRdrNames ty = nub (extract_ty ty [])
-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 :: Context RdrName -> [RdrName]
+extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
-
-extract_ctxt ctxt acc = foldr extract_ass acc ctxt
- where
- extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
-
-extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoListTy ty) acc = extract_ty ty acc
-extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
-extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
-extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
-extract_ty (MonoTyVar tv) acc = tv : acc
+extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
+extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
+
+extract_ctxt ctxt acc = foldr extract_pred acc ctxt
+
+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 (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 (HsTyVar tv) acc = tv : acc
+extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (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 (HsForAllTy (Just tvs) ctxt ty)
acc = acc ++
(filter (`notElem` locals) $
extract_ctxt ctxt (extract_ty ty []))
where
- locals = map getTyVarName tvs
-
-
-extractPatsTyVars :: [RdrNamePat] -> [RdrName]
-extractPatsTyVars pats = nub (foldr extract_pat [] pats)
-
-extract_pat (SigPatIn pat ty) acc = extract_ty ty acc
-extract_pat WildPatIn acc = acc
-extract_pat (VarPatIn var) acc = acc
-extract_pat (LitPatIn _) acc = acc
-extract_pat (LazyPatIn pat) acc = extract_pat pat acc
-extract_pat (AsPatIn a pat) acc = extract_pat pat acc
-extract_pat (NPlusKPatIn n _) acc = acc
-extract_pat (ConPatIn c pats) acc = foldr extract_pat acc pats
-extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc)
-extract_pat (NegPatIn pat) acc = extract_pat pat acc
-extract_pat (ParPatIn pat) acc = extract_pat pat acc
-extract_pat (ListPatIn pats) acc = foldr extract_pat acc pats
-extract_pat (TuplePatIn pats _) acc = foldr extract_pat acc pats
-extract_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
+ locals = hsTyVarNames tvs
+
+extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
+-- Get the type variables out of the type patterns in a bunch of
+-- possibly-generic bindings in a class declaration
+extractGenericPatTyVars binds
+ = filter isRdrTyVar (nub (get binds []))
+ where
+ get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
+ 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
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Construction functions for Rdr stuff}
+%* *
+%************************************************************************
+
mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
by deriving them from the name of the class. We fill in the names for the
tycon and datacon corresponding to the class, by deriving them from the
name of the class itself. This saves recording the names in the interface
file (which would be equally good).
-Similarly for mkClassOpSig and default-method names.
+Similarly for mkConDecl, mkClassOpSig and default-method names.
+
+ *** See "THE NAMING STORY" in HsDecls ****
\begin{code}
-mkClassDecl cxt cname tyvars sigs mbinds prags loc
- = ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_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
- dname = mkRdrUnqual (mkClassDataConOcc cls_occ)
- tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
+ cls_occ = rdrNameOcc cname
+ data_occ = mkClassDataConOcc cls_occ
+ dname = mkRdrUnqual data_occ
+ dwname = mkRdrUnqual (mkWorkerOcc data_occ)
+ tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
| n <- [1..length cxt]]
-- We number off the superclass selectors, 1, 2, 3 etc so that we
-- D_sc1, D_sc2
-- (We used to call them D_C, but now we can have two different
-- superclasses both called C!)
-
-mkClassOpSig has_default_method op ty loc
- | not has_default_method = ClassOpSig op Nothing ty loc
- | otherwise = ClassOpSig op (Just dm_rn) ty loc
+ new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
+
+mkTyData new_or_data context tname list_var list_con i maybe src
+ = let t_occ = rdrNameOcc tname
+ name1 = mkRdrUnqual (mkGenOcc1 t_occ)
+ name2 = mkRdrUnqual (mkGenOcc2 t_occ)
+ in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
+ tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
+ tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
+
+mkClassOpSigDM op ty loc
+ = ClassOpSig op (DefMeth dm_rn) ty loc
where
dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
+
+mkConDecl cname ex_vars cxt details loc
+ = ConDecl cname wkr_name ex_vars cxt details loc
+ where
+ wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
+\end{code}
+
+\begin{code}
+mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
+-- 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 negateName
+\end{code}
+
+A useful function for building @OpApps@. The operator is always a
+variable, and we don't know the fixity yet.
+
+\begin{code}
+mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
\end{code}
-A useful function for building @OpApps@. The operator is always a variable,
-and we don't know the fixity yet.
+These are the bits of syntax that contain rebindable names
+See RnEnv.lookupSyntaxName
\begin{code}
-mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
+mkHsIntegral i = HsIntegral i fromIntegerName
+mkHsFractional f = HsFractional f fromRationalName
+mkNPlusKPat n k = NPlusKPatIn n k minusName
\end{code}
+
%************************************************************************
%* *
\subsection[rdrBinding]{Bindings straight out of the parser}
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