RdrNameConDecl,
RdrNameConDetails,
RdrNameContext,
- RdrNameSpecDataSig,
RdrNameDefaultDecl,
RdrNameForeignDecl,
RdrNameGRHS,
RdrMatch(..),
SigConverter,
- RdrNameClassOpPragmas,
- RdrNameClassPragmas,
- RdrNameDataPragmas,
- RdrNameGenPragmas,
- RdrNameInstancePragmas,
extractHsTyRdrNames,
extractHsTyRdrTyVars, extractHsTysRdrTyVars,
extractPatsTyVars,
extractRuleBndrsTyVars,
- extractHsCtxtRdrTyVars,
+ extractHsCtxtRdrTyVars, extractGenericPatTyVars,
- mkOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
+ mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
+ mkHsNegApp,
cvBinds,
cvMonoBindsAndSigs,
cvTopDecls,
- cvValSig, cvClassOpSig, cvInstDeclSig
+ cvValSig, cvClassOpSig, cvInstDeclSig,
+ mkTyData
) where
#include "HsVersions.h"
-import HsSyn
+import HsSyn -- Lots of it
import HsPat ( collectSigTysFromPats )
-import Name ( mkClassTyConOcc, mkClassDataConOcc )
import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
- mkSuperDictSelOcc, mkDefaultMethodOcc
+ mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
+ mkGenOcc2,
)
-import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
-import Util ( thenCmp )
-import HsPragmas
+import PrelNames ( negate_RDR )
+import RdrName ( RdrName, isRdrTyVar, mkRdrIfaceUnqual, rdrNameOcc,
+ )
import List ( nub )
import BasicTypes ( RecFlag(..) )
-import Outputable
+import Class ( DefMeth (..) )
\end{code}
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 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}
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)
+-- 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) $
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
+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
Similarly for mkConDecl, mkClassOpSig and default-method names.
\begin{code}
-mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
- = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname dwname sc_sel_names loc
+mkClassDecl cxt cname tyvars fds sigs mbinds loc
+ = ClassDecl cxt cname tyvars fds sigs mbinds new_names loc
where
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)
+ dname = mkRdrIfaceUnqual data_occ
+ dwname = mkRdrIfaceUnqual (mkWorkerOcc data_occ)
+ tname = mkRdrIfaceUnqual (mkClassTyConOcc cls_occ)
+ sc_sel_names = [ mkRdrIfaceUnqual (mkSuperDictSelOcc n cls_occ)
| n <- [1..length cxt]]
-- We number off the superclass selectors, 1, 2, 3 etc so that we
-- can construct names for the selectors. Thus
-- 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
- = ClassOpSig op (Just (dm_rn, has_default_method)) ty loc
+ new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
+
+-- mkTyData :: ??
+mkTyData new_or_data context tname list_var list_con i maybe src
+ = let t_occ = rdrNameOcc tname
+ name1 = mkRdrIfaceUnqual (mkGenOcc1 t_occ)
+ name2 = mkRdrIfaceUnqual (mkGenOcc2 t_occ)
+ in TyData new_or_data context
+ tname list_var list_con i maybe src name1 name2
+
+mkClassOpSig (DefMeth x) op ty loc
+ = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
where
- dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
+ dm_rn = mkRdrIfaceUnqual (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
where
- wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
+ wkr_name = mkRdrIfaceUnqual (mkWorkerOcc (rdrNameOcc cname))
\end{code}
-A useful function for building @OpApps@. The operator is always a variable,
-and we don't know the fixity yet.
+\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 negate_RDR
+\end{code}
+
+A useful function for building @OpApps@. The operator is always a
+variable, and we don't know the fixity yet.
\begin{code}
-mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
+mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
\end{code}
+
%************************************************************************
%* *
\subsection[rdrBinding]{Bindings straight out of the parser}
projects / ghc-hetmet.git / blobdiff