then
Class (loop TyCon.TyCon, loop Type.Type)
then
- TyCon (loop Type.Type, loop Type.Kind, loop DataCon.DataCon)
+ TyCon (loop Type.Type, loop Type.Kind, loop DataCon.DataCon, loop Generics.GenInfo)
then
Type (loop DataCon.DataCon, loop Subst.substTy)
then
then
Literal (TysPrim, PprType), DataCon
then
- TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId)
+ TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId, loop Generics.mkGenInfo)
then
PrimOp (PprType, TysWiredIn)
then
then
CoreUnfold (OccurAnal.occurAnalyseGlobalExpr)
then
- Rules (Unfolding), Subst (Unfolding, CoreFVs), CoreTidy (noUnfolding)
+ Rules (Unfolding), Subst (Unfolding, CoreFVs), CoreTidy (noUnfolding), Generics (mkTopUnfolding)
then
MkId (CoreUnfold.mkUnfolding, Subst)
then
OccInfo(..), seqOccInfo, isFragileOcc, isDeadOcc, isLoopBreaker,
InsideLam, insideLam, notInsideLam,
- OneBranch, oneBranch, notOneBranch
+ OneBranch, oneBranch, notOneBranch,
+ EP(..)
) where
#include "HsVersions.h"
isNonRec NonRecursive = True
\end{code}
+%************************************************************************
+%* *
+\subsection[Generic]{Generic flag}
+%* *
+%************************************************************************
+
+This is the "Embedding-Projection pair" datatype, it contains
+two pieces of code (normally either RenamedHsExpr's or Id's)
+If we have a such a pair (EP from to), the idea is that 'from' and 'to'
+represents functions of type
+
+ from :: T -> Tring
+ to :: Tring -> T
+
+And we should have
+
+ to (from x) = x
+
+T and Tring are arbitrary, but typically T is the 'main' type while
+Tring is the 'representation' type. (This just helps us remember
+whether to use 'from' or 'to'.
+
+\begin{code}
+data EP a = EP { fromEP :: a, -- :: T -> Tring
+ toEP :: a } -- :: Tring -> T
+\end{code}
+
+Embedding-projection pairs are used in several places:
+
+First of all, each type constructor has an EP associated with it, the
+code in EP converts (datatype T) from T to Tring and back again.
+
+Secondly, when we are filling in Generic methods (in the typechecker,
+tcMethodBinds), we are constructing bimaps by induction on the structure
+of the type of the method signature.
+
%************************************************************************
%* *
import PprType () -- Instances
import Maybes ( maybeToBool )
import Maybe
-import Util ( assoc )
+import ListSetOps ( assoc )
\end{code}
-- Simple construction
mkId, mkVanillaId, mkSysLocal, mkUserLocal,
- mkTemplateLocals, mkWildId, mkTemplateLocal,
+ mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
-- Taking an Id apart
idName, idType, idUnique, idInfo,
isIP,
isSpecPragmaId, isRecordSelector,
isPrimOpId, isPrimOpId_maybe,
- isDataConId, isDataConId_maybe, isDataConWrapId, isDataConWrapId_maybe,
+ isDataConId, isDataConId_maybe, isDataConWrapId,
+ isDataConWrapId_maybe,
isBottomingId,
isExportedId, isUserExportedId,
hasNoBinding,
idCafInfo,
idCprInfo,
idLBVarInfo,
- idOccInfo
+ idOccInfo,
) where
#include "HsVersions.h"
-import CoreSyn ( Unfolding, CoreRules )
+import CoreSyn ( Unfolding, CoreRules, CoreExpr, Expr(..),
+ AltCon (..), Alt, mkApps, Arg )
import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, mkIdVar,
idName, idType, idUnique, idInfo,
setIdName, setVarType, setIdUnique,
- setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
+ setIdInfo, lazySetIdInfo, modifyIdInfo,
+ maybeModifyIdInfo,
externallyVisibleId
)
import VarSet
-import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe )
+import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars,
+ seqType, splitAlgTyConApp_maybe, mkTyVarTy,
+ mkTyConApp, splitTyConApp_maybe)
import IdInfo
import TysPrim ( statePrimTyCon )
import FieldLabel ( FieldLabel )
import SrcLoc ( SrcLoc )
-import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques )
+import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques,
+ getNumBuiltinUniques )
import Outputable
-
+import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon,
+ mkAlgTyConRep, tyConName,
+ tyConTyVars, tyConDataCons )
+import DataCon ( DataCon, dataConWrapId, dataConOrigArgTys )
+import Var ( Var )
infixl 1 `setIdUnfolding`,
`setIdArityInfo`,
`setIdDemandInfo`,
(getBuiltinUniques (length tys))
tys
+mkTemplateLocalsNum :: Int -> [Type] -> [Id]
+mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl"))
+ (getNumBuiltinUniques n (length tys))
+ tys
+
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
\end{code}
zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
\end{code}
+
+
+
+
+
+
+
+
+
+
import PrelNames ( pREL_ERR, pREL_GHC )
import PrelRules ( primOpRule )
import Rules ( addRule )
-import Type ( Type, ClassContext, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys,
+import Type ( Type, ThetaType, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys,
mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes,
splitSigmaTy, splitFunTy_maybe,
import PrelNames
import Maybe ( isJust )
import Outputable
-import Util ( assoc )
+import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
import Char ( ord )
\end{code}
-- is 'open'; that is can be unified with an unboxed type
--
-- [The interface file format now carry such information, but there's
- -- no way yet of expressing at the definition site for these error-reporting
- -- functions that they have an 'open' result type. -- sof 1/99]
+ -- no way yet of expressing at the definition site for these
+ -- error-reporting
+ -- functions that they have an 'open' result type. -- sof 1/99]
aBSENT_ERROR_ID
, eRROR_ID
-> Class
-> [TyVar]
-> [Type]
- -> ClassContext
+ -> ThetaType
-> Id
-mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
+mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
= mkVanillaId dfun_name dfun_ty
where
- dfun_theta = classesToPreds inst_decl_theta
+ dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
{- 1 dec 99: disable the Mark Jones optimisation for the sake
of compatibility with Hugs.
-- instance Wob b => Baz T b where..
-- Now sc_theta' has Foo T
-}
- dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
\end{code}
mkLocalName, mkImportedLocalName, mkSysLocalName, mkCCallName,
mkTopName, mkIPName,
mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
- mkWiredInIdName, mkWiredInTyConName,
+ mkWiredInIdName, mkWiredInTyConName,
mkUnboundName, isUnboundName,
maybeWiredInIdName, maybeWiredInTyConName,
nameSrcLoc, isLocallyDefinedName, isDllName,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
+ isTyVarName,
-- Environment
NameEnv, mkNameEnv,
n_occ = occ, n_prov = prov }
-mkKnownKeyGlobal :: (RdrName, Unique) -> Name
-mkKnownKeyGlobal (rdr_name, uniq)
+mkKnownKeyGlobal :: RdrName -> Unique -> Name
+mkKnownKeyGlobal rdr_name uniq
= mkGlobalName uniq (mkVanillaModule (rdrNameModule rdr_name))
(rdrNameOcc rdr_name)
systemProvenance
mkWiredInIdName uniq mod occ id = Name { n_uniq = uniq, n_sort = WiredInId mod id,
n_occ = occ, n_prov = SystemProv }
--- mkWiredInTyConName takes a FAST_STRING instead of
--- an OccName, which is a bit yukky but that's what the
--- clients find easiest.
-mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name
-mkWiredInTyConName uniq mod fs tycon
+mkWiredInTyConName :: Unique -> Module -> OccName -> TyCon -> Name
+mkWiredInTyConName uniq mod occ tycon
= Name { n_uniq = uniq, n_sort = WiredInTyCon mod tycon,
- n_occ = mkSrcOccFS tcName fs, n_prov = SystemProv }
+ n_occ = occ, n_prov = SystemProv }
---------------------------------------------------------------------
isGlobalName (Name {n_sort = Local}) = False
isGlobalName other = True
+isTyVarName :: Name -> Bool
+isTyVarName name = isTvOcc (nameOccName name)
+
-- Global names are by definition those that are visible
-- outside the module, *as seen by the linker*. Externally visible
-- does not mean visible at the source level (that's isExported).
unitNameEnv :: Name -> a -> NameEnv a
lookupNameEnv :: NameEnv a -> Name -> Maybe a
lookupNameEnv_NF :: NameEnv a -> Name -> a
+mapNameEnv :: (a->b) -> NameEnv a -> NameEnv b
emptyNameEnv = emptyUFM
mkNameEnv = listToUFM
extendNameEnvList= addListToUFM
delFromNameEnv = delFromUFM
elemNameEnv = elemUFM
+mapNameEnv = mapUFM
unitNameEnv = unitUFM
lookupNameEnv = lookupUFM
NameSet,
emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet,
- delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet
+ delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet
) where
#include "HsVersions.h"
delFromNameSet :: NameSet -> Name -> NameSet
delListFromNameSet :: NameSet -> [Name] -> NameSet
foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b
+filterNameSet :: (Name -> Bool) -> NameSet -> NameSet
isEmptyNameSet = isEmptyUniqSet
emptyNameSet = emptyUniqSet
nameSetToList = uniqSetToList
delFromNameSet = delOneFromUniqSet
foldNameSet = foldUniqSet
+filterNameSet = filterUniqSet
delListFromNameSet set ns = foldl delFromNameSet set ns
\end{code}
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
+ mkGenOcc1, mkGenOcc2,
isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
mkIPOcc = mk_simple_deriv varName "$i"
mkSpecOcc = mk_simple_deriv varName "$s"
mkForeignExportOcc = mk_simple_deriv varName "$f"
-
+mkGenOcc1 = mk_simple_deriv varName "$gfrom" -- Generics
+mkGenOcc2 = mk_simple_deriv varName "$gto" -- Generics
mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
mkPreludeTyConUnique, mkPreludeClassUnique,
- getBuiltinUniques, mkBuiltinUnique,
+ getNumBuiltinUniques, getBuiltinUniques, mkBuiltinUnique,
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
) where
mkAlphaTyVarUnique i = mkUnique '1' i
mkPreludeClassUnique i = mkUnique '2' i
-mkPreludeTyConUnique i = mkUnique '3' i
+mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' a
mkTupleTyConUnique Unboxed a = mkUnique '5' a
getBuiltinUniques :: Int -> [Unique]
getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
+
+getNumBuiltinUniques :: Int -- First unique
+ -> Int -- Number required
+ -> [Unique]
+getNumBuiltinUniques base n = map (mkUnique 'B') [base .. base+n-1]
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.35 2000/07/11 16:03:37 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.36 2000/10/03 08:43:00 simonpj Exp $
%
%********************************************************
%* *
import TyCon ( maybeTyConSingleCon,
isUnboxedTupleTyCon, isEnumerationTyCon )
import Type ( Type, typePrimRep, splitTyConApp_maybe, repType )
-import Maybes ( assocMaybe, maybeToBool )
+import Maybes ( maybeToBool )
+import ListSetOps ( assocMaybe )
import Unique ( mkBuiltinUnique )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import Outputable
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.26 2000/07/14 08:14:53 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.27 2000/10/03 08:43:00 simonpj Exp $
%
%********************************************************
%* *
import CmdLineOpts ( opt_DoSemiTagging )
import Id ( Id, idType, idName )
import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
-import Maybes ( assocMaybe, maybeToBool )
+import Maybes ( maybeToBool )
import PrimRep ( PrimRep(..) )
import StgSyn ( StgArg, GenStgArg(..) )
import Type ( isUnLiftedType )
import TyCon ( TyCon )
import PrimOp ( PrimOp )
import Util ( zipWithEqual )
+import ListSetOps ( assocMaybe )
import Unique ( mkPseudoUnique1 )
import Outputable
import Panic ( panic, assertPanic )
import Id ( Id )
import CoreSyn
import Type ( mkTyVarTys )
-import Util ( equivClassesByUniq )
+import ListSetOps ( equivClassesByUniq )
import Unique ( Uniquable(..) )
\end{code}
import Outputable
import SrcLoc ( SrcLoc )
import Var ( TyVar )
+import Class ( DefMeth (..) )
\end{code}
%************************************************************************
(HsType name)
SrcLoc
- | ClassOpSig name -- Selector name
- (Maybe -- Nothing for source-file class signatures
- (name, -- Default-method name (if any)
- Bool)) -- True <=> there is an explicit, programmer-supplied
- -- default declaration in the class decl
+ | ClassOpSig name -- Selector name
+ (Maybe (DefMeth name)) -- Nothing for source-file class signatures
+ -- Gives DefMeth info for interface files sigs
(HsType name)
SrcLoc
= sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
where
pp_dm = case dm of
- Just (_, True) -> equals -- Default-method indicator
- other -> empty
+ Just (DefMeth _) -> equals -- Default method indicator
+ Just GenDefMeth -> semi -- Generic method indicator
+ Just NoDefMeth -> empty -- No Method at all
+ -- Not convinced this is right...
+ -- Not used in interface file output hopefully
+ -- but needed for ddump-rn ??
+ other -> dot
+ -- empty -- No method at all
+
ppr_sig (SpecSig var ty _)
= sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
BangType(..), getBangType,
IfaceSig(..), SpecDataSig(..),
DeprecDecl(..), DeprecTxt,
- hsDeclName, instDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule
+ hsDeclName, instDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
+ toClassDeclNameList,
+ fromClassDeclNameList
+
) where
#include "HsVersions.h"
tyClDeclName :: TyClDecl name pat -> name
-tyClDeclName (TyData _ _ name _ _ _ _ _ _) = name
+tyClDeclName (TyData _ _ name _ _ _ _ _ _ _ _) = name
tyClDeclName (TySynonym name _ _ _) = name
-tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _ _ _) = name
+tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ ) = name
instDeclName :: InstDecl name pat -> name
instDeclName (InstDecl _ _ _ (Just name) _) = name
+
\end{code}
\begin{code}
-- expect...
(DataPragmas name)
SrcLoc
+ name -- generic converter functions
+ name -- generic converter functions
- | TySynonym name -- type constructor
- [HsTyVarBndr name] -- type variables
- (HsType name) -- synonym expansion
+ | TySynonym name -- type constructor
+ [HsTyVarBndr name] -- type variables
+ (HsType name) -- synonym expansion
SrcLoc
| ClassDecl (HsContext name) -- context...
[Sig name] -- methods' signatures
(MonoBinds name pat) -- default methods
(ClassPragmas name)
- name name name [name] -- The names of the tycon, datacon wrapper, datacon worker,
- -- and superclass selectors for this class.
- -- These are filled in as the ClassDecl is made.
+ [name] -- The names of the tycon, datacon
+ -- wrapper, datacon worker,
+ -- and superclass selectors for this
+ -- class (the first 3 are at the front
+ -- of the list in this order)
+ -- These are filled in as the
+ -- ClassDecl is made.
SrcLoc
+-- Put type signatures in and explain further!!
+ -- The names of the tycon, datacon
+ -- wrapper, datacon worker,
+ -- and superclass selectors for this
+ -- class (the first 3 are at the front
+ -- of the list in this order)
+ -- These are filled in as the
+toClassDeclNameList (a,b,c,ds) = a:b:c:ds
+fromClassDeclNameList (a:b:c:ds) = (a,b,c,ds)
+
instance Ord name => Eq (TyClDecl name pat) where
-- Used only when building interface files
- (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _)
- (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _)
+ (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _ _)
+ (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _ _)
= n1 == n2 &&
nd1 == nd2 &&
eqWithHsTyVars tvs1 tvs2 (\ env ->
= n1 == n2 &&
eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2)
- (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ _ _ _ _)
- (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ _ _ _ _)
+ (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ _ )
+ (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ _ )
= n1 == n2 &&
eqWithHsTyVars tvs1 tvs2 (\ env ->
eq_hsContext env cxt1 cxt2 &&
-- This is used for comparing declarations before putting
-- them into interface files, and the name of the default
-- method isn't relevant
- (Just (_,explicit_dm1)) `eq_dm` (Just (_,explicit_dm2)) = explicit_dm1 == explicit_dm2
+ (Just (explicit_dm1)) `eq_dm` (Just (explicit_dm2)) = explicit_dm1 == explicit_dm2
Nothing `eq_dm` Nothing = True
dm1 `eq_dm` dm2 = False
\end{code}
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
-- class, data, newtype, synonym decls
countTyClDecls decls
- = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ _ _ <- decls],
- length [() | TyData DataType _ _ _ _ _ _ _ _ <- decls],
- length [() | TyData NewType _ _ _ _ _ _ _ _ <- decls],
+ = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ <- decls],
+ length [() | TyData DataType _ _ _ _ _ _ _ _ _ _ <- decls],
+ length [() | TyData NewType _ _ _ _ _ _ _ _ _ _ <- decls],
length [() | TySynonym _ _ _ _ <- decls])
isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other = False
-isDataDecl (TyData _ _ _ _ _ _ _ _ _) = True
-isDataDecl other = False
+isDataDecl (TyData _ _ _ _ _ _ _ _ _ _ _) = True
+isDataDecl other = False
-isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _ _) = True
+isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ ) = True
isClassDecl other = False
\end{code}
= hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
4 (ppr mono_ty)
- ppr (TyData new_or_data context tycon tyvars condecls ncons derivings pragmas src_loc)
+ ppr (TyData new_or_data context tycon tyvars condecls ncons derivings pragmas src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM
= pp_tydecl
(ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
(pp_condecls condecls ncons)
NewType -> SLIT("newtype")
DataType -> SLIT("data")
- ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ _ _ _ src_loc)
+ ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ src_loc)
| null sigs -- No "where" part
= top_matter
| HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation
(HsExpr id pat) -- expr whose cost is to be measured
+
\end{code}
These constructors only appear temporarily in the parser.
(HsExpr id pat)
| ELazyPat (HsExpr id pat) -- ~ pattern
+
+ | HsType (HsType id) -- Explicit type argument; e.g f {| Int |} x y
\end{code}
Everything from here on appears only in typechecker output.
= hang (ppr_expr expr)
4 (brackets (interpp'SP dnames))
+ppr_expr (HsType id) = ppr id
+
\end{code}
Parenthesize unless very simple:
import HsExpr ( HsExpr, Stmt(..) )
import HsBinds ( HsBinds(..), nullBinds )
import HsTypes ( HsTyVarBndr, HsType )
-
-- Others
import Type ( Type )
import SrcLoc ( SrcLoc )
import Outputable
+import HsPat ( InPat (..) )
+import List
\end{code}
%************************************************************************
\begin{code}
data Match id pat
= Match
- [HsTyVarBndr id] -- Tyvars wrt which this match is universally quantified
- -- empty after typechecking
- [pat] -- The patterns
- (Maybe (HsType id)) -- A type signature for the result of the match
- -- Nothing after typechecking
+ [id] -- Tyvars wrt which this match is universally quantified
+ -- empty after typechecking
+ [pat] -- The patterns
+ (Maybe (HsType id)) -- A type signature for the result of the match
+ -- Nothing after typechecking
(GRHSs id pat)
ExprStmt expr _ = last guarded -- Last stmt should be a ExprStmt for guards
guards = init guarded
\end{code}
+
| RecPatIn name -- record
[(name, InPat name, Bool)] -- True <=> source used punning
+-- Generics
+ | TypePatIn (HsType name) -- Type pattern for generic definitions
+ -- e.g f{| a+b |} = ...
+ -- These show up only in class
+ -- declarations,
+ -- and should be a top-level pattern
+
+-- /Generics
+
data OutPat id
= WildPat Type -- wild card
| VarPat id -- variable (type is in the Id)
where
pp_rpat (v, _, True) = ppr v
pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p]
+
+pprInPat (TypePatIn ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
\end{code}
\begin{code}
collect (ListPatIn pats) bndrs = foldr collect bndrs pats
collect (TuplePatIn pats _) bndrs = foldr collect bndrs pats
collect (RecPatIn c fields) bndrs = foldr (\ (f,pat,_) bndrs -> collect pat bndrs) bndrs fields
+-- Generics
+collect (TypePatIn ty) bndrs = bndrs
+-- assume the type variables do not need to be bound
\end{code}
-
\begin{code}
collectSigTysFromPats :: [InPat name] -> [HsType name]
collectSigTysFromPats pats = foldr collect_pat [] pats
collect_pat (ListPatIn pats) acc = foldr collect_pat acc pats
collect_pat (TuplePatIn pats _) acc = foldr collect_pat acc pats
collect_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> collect_pat pat acc) acc fields
+-- Generics
+collect_pat (TypePatIn ty) acc = ty:acc
\end{code}
+
module HsTypes,
Fixity, NewOrData,
- collectTopBinders, collectMonoBinders
+ collectTopBinders, collectMonoBinders, collectLocatedMonoBinders
) where
#include "HsVersions.h"
\begin{code}
collectTopBinders :: HsBinds name (InPat name) -> Bag (name,SrcLoc)
-collectTopBinders EmptyBinds = emptyBag
-collectTopBinders (MonoBind b _ _) = collectMonoBinders b
-collectTopBinders (ThenBinds b1 b2)
- = collectTopBinders b1 `unionBags` collectTopBinders b2
-
-collectMonoBinders :: MonoBinds name (InPat name) -> Bag (name,SrcLoc)
-collectMonoBinders EmptyMonoBinds = emptyBag
-collectMonoBinders (PatMonoBind pat _ loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
-collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc)
-collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
-collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders"
-collectMonoBinders (AndMonoBinds bs1 bs2) = collectMonoBinders bs1 `unionBags`
- collectMonoBinders bs2
+collectTopBinders EmptyBinds = emptyBag
+collectTopBinders (MonoBind b _ _) = listToBag (collectLocatedMonoBinders b)
+collectTopBinders (ThenBinds b1 b2) = collectTopBinders b1 `unionBags` collectTopBinders b2
+
+collectLocatedMonoBinders :: MonoBinds name (InPat name) -> [(name,SrcLoc)]
+collectLocatedMonoBinders binds
+ = go binds []
+ where
+ go EmptyMonoBinds acc = acc
+ go (PatMonoBind pat _ loc) acc = map (\v->(v,loc)) (collectPatBinders pat) ++ acc
+ go (FunMonoBind f _ _ loc) acc = (f,loc) : acc
+ go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
+
+collectMonoBinders :: MonoBinds name (InPat name) -> [name]
+collectMonoBinders binds
+ = go binds []
+ where
+ go EmptyMonoBinds acc = acc
+ go (PatMonoBind pat _ loc) acc = collectPatBinders pat ++ acc
+ go (FunMonoBind f _ _ loc) acc = f : acc
+ go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
\end{code}
-
#include "HsVersions.h"
+import {-# SOURCE #-} HsExpr ( HsExpr )
import Class ( FunDep )
import Type ( Type, Kind, PredType(..), UsageAnn(..), ClassContext,
getTyVar_maybe, splitSigmaTy, unUsgTy, boxedTypeKind
import Maybes ( maybeToBool )
import FiniteMap
import Outputable
+
\end{code}
This is the syntax for types as seen in type signatures.
(HsContext name)
(HsType name)
- | HsTyVar name -- Type variable
+ | HsTyVar name -- Type variable or type constructor
| HsAppTy (HsType name)
(HsType name)
| HsTupleTy (HsTupCon name)
[HsType name] -- Element types (length gives arity)
-
+ -- Generics
+ | HsOpTy (HsType name) name (HsType name)
+ | HsNumTy Integer
-- these next two are only used in interfaces
| HsPredTy (HsPred name)
HsUsOnce -> ptext SLIT("-")
HsUsMany -> ptext SLIT("!")
HsUsVar uv -> ppr uv
+-- Generics
+ppr_mono_ty ctxt_prec (HsNumTy n) = integer n
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = ppr ty1 <+> ppr op <+> ppr ty2
\end{code}
eq_hsType env (HsPredTy p1) (HsPredTy p2)
= eq_hsPred env p1 p2
+eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2)
+ = eq_hsVar env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2
+
eq_hsType env (HsUsgTy u1 ty1) (HsUsgTy u2 ty2)
= eqUsg u1 u2 && eq_hsType env ty1 ty2
import Constants -- Default values for some flags
import FastString ( headFS )
-import Maybes ( assocMaybe, firstJust, maybeToBool )
+import Maybes ( firstJust, maybeToBool )
import Panic ( panic, panic# )
#if __GLASGOW_HASKELL__ < 301
lookup_def_float :: String -> Float -> Float
lookup_str :: String -> Maybe String
-lookUp sw = maybeToBool (assoc_opts sw)
+lookUp sw = sw `elem` argv
lookup_str sw = firstJust (map (startsWith sw) unpacked_opts)
Nothing -> def -- Use default
Just xx -> read xx
-assoc_opts = assocMaybe [ (a, True) | a <- argv ]
unpacked_opts = map _UNPK_ argv
{-
a pure Win32 application where I think there's a command-line
length limit of 255. unpacked_opts understands the @ option.
-assoc_opts = assocMaybe [ (_PK_ a, True) | a <- unpacked_opts ]
-
unpacked_opts :: [String]
unpacked_opts =
concat $
import IOExts ( unsafePerformIO )
import NativeInfo ( os, arch )
#endif
-#ifdef GHCI
import StgInterp ( runStgI )
-import CompManager
-#endif
\end{code}
doIt (core_cmds, stg_cmds)
= doIfSet opt_Verbose
- (hPutStr stderr "Glasgow Haskell Compiler, version " >>
+ (hPutStr stderr "Glasgow Haskell Compiler, Version " >>
hPutStr stderr compiler_version >>
hPutStr stderr ", for Haskell 98, compiled by GHC version " >>
hPutStr stderr booter_version >>
spec_info (Just (False, _)) = (0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,1)
- data_info (TyData _ _ _ _ _ nconstrs derivs _ _)
+ data_info (TyData _ _ _ _ _ nconstrs derivs _ _ _ _)
= (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds})
data_info other = (0,0)
- class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ _ _ _)
+ class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ )
= case count_sigs meth_sigs of
(_,classops,_,_) ->
(classops, addpr (count_monobinds def_meths))
import HsSyn
import HsCore ( HsIdInfo(..), toUfExpr )
-import RdrHsSyn ( RdrNameRuleDecl )
+import RdrHsSyn ( RdrNameRuleDecl, mkTyData )
import HsPragmas ( DataPragmas(..), ClassPragmas(..) )
import HsTypes ( toHsTyVars )
import BasicTypes ( Fixity(..), NewOrData(..),
import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
idSpecialisation
)
-import Var ( isId )
+import Var ( isId, varName )
import VarSet
import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..),
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
)
-import Class ( classExtraBigSig )
+import Class ( classExtraBigSig, DefMeth(..) )
import FieldLabel ( fieldLabelType )
import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
deNoteType, classesToPreds
Just final_iface ->
do let mod_vers_unchanged = case old_iface of
- Just iface -> pi_vers iface == pi_vers final_iface
- Nothing -> False
+ Just iface -> pi_vers iface == pi_vers final_iface
+ Nothing -> False
when (mod_vers_unchanged && opt_D_dump_rn_trace) $
putStrLn "Module version unchanged, but usages differ; hence need new hi file"
-- instance Foo Tibble where ...
-- and this instance decl wouldn't get imported into a module
-- that mentioned T but not Tibble.
- forall_ty = mkSigmaTy tvs (classesToPreds theta)
- (deNoteType (mkDictTy clas tys))
+ forall_ty = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys))
tidy_ty = tidyTopType forall_ty
in
InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc
ifaceTyCon tycon
| isAlgTyCon tycon
- = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon))
+ = TyClD (mkTyData new_or_data (toHsContext (tyConTheta tycon))
(toRdrName tycon)
(toHsTyVars tyvars)
(map ifaceConDecl (tyConDataCons tycon))
(toHsFDs clas_fds)
(map toClassOpSig op_stuff)
EmptyMonoBinds NoClassPragmas
- bogus bogus bogus [] noSrcLoc
+ [] noSrcLoc
)
where
bogus = error "ifaceClass"
(clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
- toClassOpSig (sel_id, dm_id, explicit_dm)
- = ASSERT( sel_tyvars == clas_tyvars)
- ClassOpSig (toRdrName sel_id) (Just (bogus, explicit_dm)) (toHsType op_ty) noSrcLoc
+ toClassOpSig (sel_id, def_meth) =
+ ASSERT(sel_tyvars == clas_tyvars)
+ ClassOpSig (toRdrName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
where
(sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
+ def_meth' = case def_meth of
+ NoDefMeth -> NoDefMeth
+ GenDefMeth -> GenDefMeth
+ DefMeth id -> DefMeth (toRdrName id)
\end{code}
%************************************************************************
%* *
\subsection{Value bindings}
-%* *
+%* *
%************************************************************************
\begin{code}
find_fvs expr = exprSomeFreeVars interestingId expr
-
interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
\end{code}
| ITocurly -- special symbols
| ITccurly
+ | ITocurlybar -- {|, for type applications
+ | ITccurlybar -- |}, for type applications
| ITvccurly
| ITobrack
| ITcbrack
where
line = srcLocLine loc
- tab y bol atbol buf = --trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
+ tab y bol atbol buf = -- trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
case currentChar# buf of
'\NUL'# ->
-- and throw out any unrecognised pragmas as comments. Any
-- pragmas we know about are dealt with later (after any layout
-- processing if necessary).
-
- '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
+ '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
if lookAhead# buf 2# `eqChar#` '#'# then
if lookAhead# buf 3# `eqChar#` '#'# then is_a_token else
case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1->
loop buf =
case currentChar# buf of
'\NUL'# | bufferExhausted (stepOn buf) ->
- lexError "unterminated `{-'" buf
-
+ lexError "unterminated `{-'" buf -- -}
'-'# | lookAhead# buf 1# `eqChar#` '}'# ->
cont (stepOnBy# buf 2#)
lexToken :: (Token -> P a) -> Int# -> P a
lexToken cont glaexts buf =
- --trace "lexToken" $
+ -- trace "lexToken" $
case currentChar# buf of
-- special symbols ----------------------------------------------------
']'# -> cont ITcbrack (incLexeme buf)
','# -> cont ITcomma (incLexeme buf)
';'# -> cont ITsemi (incLexeme buf)
-
'}'# -> \ s@PState{context = ctx} ->
case ctx of
(_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
_ -> lexError "too many '}'s" buf s
+ '|'# -> case lookAhead# buf 1# of
+ '}'# | flag glaexts -> cont ITccurlybar
+ (setCurrentPos# buf 2#)
+ _ -> lex_sym cont (incLexeme buf)
+
'#'# -> case lookAhead# buf 1# of
')'# | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#)
'-'# -> case lookAhead# buf 2# of
-> cont ITbackquote (incLexeme buf)
'{'# -> -- look for "{-##" special iface pragma
- case lookAhead# buf 1# of
+ case lookAhead# buf 1# of
+ '|'# | flag glaexts
+ -> cont ITocurlybar (setCurrentPos# buf 2#)
'-'# -> case lookAhead# buf 2# of
'#'# -> case lookAhead# buf 3# of
- '#'# ->
+ '#'# ->
let (lexeme, buf')
= doDiscard False (stepOnBy# (stepOverLexeme buf) 4#) in
- cont (ITpragma lexeme) buf'
+ cont (ITpragma lexeme) buf'
_ -> lex_prag cont (setCurrentPos# buf 3#)
- _ -> cont ITocurly (incLexeme buf)
- _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf)
+ _ -> cont ITocurly (incLexeme buf)
+ _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf)
-- strings/characters -------------------------------------------------
'\"'#{-"-} -> lex_string cont glaexts [] (incLexeme buf)
}}}
lex_sym cont buf =
+ -- trace "lex_sym" $
case expandWhile# is_symbol buf of
buf' -> case lookupUFM haskellKeySymsFM lexeme of {
Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
lex_con cont glaexts buf =
+ -- trace ("con: "{-++unpackFS lexeme-}) $
case expandWhile# is_ident buf of { buf1 ->
case slurp_trailing_hashes buf1 glaexts of { buf' ->
_ -> just_a_conid
where
- just_a_conid = --trace ("con: "++unpackFS lexeme) $
- cont (ITconid lexeme) buf'
+ just_a_conid = cont (ITconid lexeme) buf'
lexeme = lexemeToFastString buf'
munch = lex_qid cont glaexts lexeme (incLexeme buf') just_a_conid
}}
lex_qid cont glaexts mod buf just_a_conid =
+ -- trace ("quid: "{-++unpackFS lexeme-}) $
case currentChar# buf of
'['# -> -- Special case for []
case lookAhead# buf 1# of
let
start_new_lexeme = stepOverLexeme buf
in
+ -- trace ("lex_id31 "{-++unpackFS lexeme-}) $
case expandWhile# is_symbol start_new_lexeme of { buf' ->
let
lexeme = lexemeToFastString buf'
let
start_new_lexeme = stepOverLexeme buf
in
+ -- trace ("lex_id32 "{-++unpackFS lexeme-}) $
case expandWhile# is_ident start_new_lexeme of { buf1 ->
if emptyLexeme buf1
then just_a_conid
| otherwise = ITvarsym pk_str
where
(C# f) = _HEAD_ pk_str
+ -- tl = _TAIL_ pk_str
mk_qvar_token m token =
+-- trace ("mk_qvar ") $
case mk_var_token token of
ITconid n -> ITqconid (m,n)
ITvarid n -> ITqvarid (m,n)
splitForConApp t ts = split t ts
where
split (HsAppTy t u) ts = split t (Unbanged u : ts)
-
+{- split (HsOpTy t1 t ty2) ts =
+ -- check that we've got a type constructor at the head
+ if occNameSpace t_occ /= tcClsName
+ then parseError
+ (showSDoc (text "not a constructor: (type pattern)`" <>
+ ppr t <> char '\''))
+ else returnP (con, ts)
+ where t_occ = rdrNameOcc t
+ con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
+-}
split (HsTyVar t) ts =
-- check that we've got a type constructor at the head
if occNameSpace t_occ /= tcClsName
checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
checkDictTy _ _ = parseError "Illegal class assertion"
+-- Put more comments!
+-- Checks that the lhs of a datatype declaration
+-- is of the form Context => T a b ... z
checkDataHeader :: RdrNameHsType
-> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
+
checkDataHeader (HsForAllTy Nothing cs t) =
checkSimple t [] `thenP` \(c,ts) ->
returnP (cs,c,map UserTyVar ts)
checkSimple t [] `thenP` \(c,ts) ->
returnP ([],c,map UserTyVar ts)
+-- Checks the type part of the lhs of a datatype declaration
checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
= checkSimple l (a:xs)
-checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
-checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
+checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
+
+checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
+ | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
+ = returnP (tycon,[t1,t2])
+
+checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"
---------------------------------------------------------------------------
-- Checking Patterns.
-- We parse patterns as expressions and check for valid patterns below,
--- nverting the expression into a pattern at the same time.
+-- converting the expression into a pattern at the same time.
checkPattern :: RdrNameHsExpr -> P RdrNamePat
checkPattern e = checkPat e []
RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
returnP (RecPatIn c fs)
+-- Generics
+ HsType ty -> returnP (TypePatIn ty)
_ -> patFail
checkPat _ _ = patFail
-- A variable binding is parsed as an RdrNameFunMonoBind.
-- See comments with HsBinds.MonoBinds
+isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
= Just (op, True, (l:r:es))
isFunLhs (HsVar f) es | not (isRdrDataCon f)
-- it's external name will be "++". Too bad; it's important because we don't
-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
-- (This is why we use occNameUserString.)
+
mkExtName :: Maybe ExtName -> RdrName -> ExtName
mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
Nothing
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.36 2000/09/22 15:56:13 simonpj Exp $
+$Id: Parser.y,v 1.37 2000/10/03 08:43:02 simonpj Exp $
Haskell grammar.
import HsSyn
import HsPragmas
import HsTypes ( mkHsTupCon )
+import HsPat ( InPat(..) )
import RdrHsSyn
import Lex
import GlaExts
import FastString ( tailFS )
+import Outputable
#include "HsVersions.h"
}
'{' { ITocurly } -- special symbols
'}' { ITccurly }
+ '{|' { ITocurlybar }
+ '|}' { ITccurlybar }
vccurly { ITvccurly } -- virtual close curly (from layout)
'[' { ITobrack }
']' { ITcbrack }
| srcloc 'data' ctype '=' constrs deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
- (TyData DataType cs c ts (reverse $5) (length $5) $6
+ (mkTyData DataType cs c ts (reverse $5) (length $5) $6
NoDataPragmas $1))) }
| srcloc 'newtype' ctype '=' newconstr deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
- (TyData NewType cs c ts [$5] 1 $6
+ (mkTyData NewType cs c ts [$5] 1 $6
NoDataPragmas $1))) }
| srcloc 'class' ctype fds where
| sigtypes ',' sigtype { $3 : $1 }
sigtype :: { RdrNameHsType }
- : ctype { mkHsForAllTy Nothing [] $1 }
+ : ctype { (mkHsForAllTy Nothing [] $1) }
sig_vars :: { [RdrName] }
: sig_vars ',' var { $3 : $1 }
ctype :: { RdrNameHsType }
: 'forall' tyvars '.' ctype { mkHsForAllTy (Just $2) [] $4 }
| context type { mkHsForAllTy Nothing $1 $2 }
- -- A type of form (context => type) is an *implicit* HsForAllTy
+ -- A type of form (context => type) is an *implicit* HsForAllTy
| type { $1 }
type :: { RdrNameHsType }
- : btype '->' type { HsFunTy $1 $3 }
+ : gentype '->' type { HsFunTy $1 $3 }
| ipvar '::' type { mkHsIParamTy $1 $3 }
- | btype { $1 }
+ | gentype { $1 }
+
+gentype :: { RdrNameHsType }
+ : btype { $1 }
+-- Generics
+ | atype tyconop atype { HsOpTy $1 $2 $3 }
btype :: { RdrNameHsType }
- : btype atype { HsAppTy $1 $2 }
+ : btype atype { (HsAppTy $1 $2) }
| atype { $1 }
atype :: { RdrNameHsType }
| '(' type ',' types ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2 : reverse $4) }
| '(#' types '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) (reverse $2) }
| '[' type ']' { HsListTy $2 }
- | '(' ctype ')' { $2 }
+ | '(' ctype ')' { $2 }
+-- Generics
+ | INTEGER { HsNumTy $1 }
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
-}
valdef :: { RdrBinding }
- : infixexp srcloc opt_sig rhs {% checkValDef $1 $3 $4 $2 }
- | infixexp srcloc '::' sigtype {% checkValSig $1 $4 $2 }
+ : infixexp srcloc opt_sig rhs {% (checkValDef $1 $3 $4 $2) }
+ | infixexp srcloc '::' sigtype {% (checkValSig $1 $4 $2) }
| var ',' sig_vars srcloc '::' sigtype { foldr1 RdrAndBindings
[ RdrSig (Sig n $6 $4) | n <- $1:$3 ]
- }
+ }
+
rhs :: { RdrNameGRHSs }
- : '=' srcloc exp wherebinds { GRHSs (unguardedRHS $3 $2)
- $4 Nothing}
+ : '=' srcloc exp wherebinds { (GRHSs (unguardedRHS $3 $2)
+ $4 Nothing)}
| gdrhs wherebinds { GRHSs (reverse $1) $2 Nothing }
gdrhs :: { [RdrNameGRHS] }
-- Expressions
exp :: { RdrNameHsExpr }
- : infixexp '::' sigtype { ExprWithTySig $1 $3 }
+ : infixexp '::' sigtype { (ExprWithTySig $1 $3) }
| infixexp 'with' dbinding { HsWith $1 $3 }
| infixexp { $1 }
infixexp :: { RdrNameHsExpr }
: exp10 { $1 }
- | infixexp qop exp10 { OpApp $1 $2 (panic "fixity") $3 }
+ | infixexp qop exp10 { (OpApp $1 (HsVar $2)
+ (panic "fixity") $3 )}
exp10 :: { RdrNameHsExpr }
: '\\' aexp aexps opt_asig '->' srcloc exp
| CONID { $1 }
fexp :: { RdrNameHsExpr }
- : fexp aexp { HsApp $1 $2 }
+ : fexp aexp { (HsApp $1 $2) }
| aexp { $1 }
aexps0 :: { [RdrNameHsExpr] }
- : aexps { reverse $1 }
+ : aexps { (reverse $1) }
aexps :: { [RdrNameHsExpr] }
: aexps aexp { $2 : $1 }
| {- empty -} { [] }
aexp :: { RdrNameHsExpr }
- : aexp '{' fbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) }
- | aexp1 { $1 }
+ : var_or_con '{|' gentype '|}' { (HsApp $1 (HsType $3)) }
+ | aexp '{' fbinds '}' {% (mkRecConstrOrUpdate $1
+ (reverse $3)) }
+ | aexp1 { $1 }
+
+var_or_con :: { RdrNameHsExpr }
+ : qvar { HsVar $1 }
+ | gcon { HsVar $1 }
aexp1 :: { RdrNameHsExpr }
- : qvar { HsVar $1 }
- | ipvar { HsIPVar $1 }
- | gcon { HsVar $1 }
+ : ipvar { HsIPVar $1 }
+ | var_or_con { $1 }
| literal { HsLit $1 }
| INTEGER { HsOverLit (mkHsIntegralLit $1) }
| RATIONAL { HsOverLit (mkHsFractionalLit $1) }
| '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed}
| '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed }
| '[' list ']' { $2 }
- | '(' infixexp qop ')' { SectionL $2 $3 }
- | '(' qopm infixexp ')' { SectionR $2 $3 }
+ | '(' infixexp qop ')' { (SectionL $2 (HsVar $3)) }
+ | '(' qopm infixexp ')' { (SectionR $2 $3) }
| qvar '@' aexp { EAsPat $1 $3 }
| '_' { EWildPat }
| '~' aexp1 { ELazyPat $2 }
: texps ',' exp { $3 : $1 }
| exp { [$1] }
+
-----------------------------------------------------------------------------
-- List expressions
alt :: { RdrNameMatch }
: infixexp opt_sig ralt wherebinds
- {% checkPattern $1 `thenP` \p ->
+ {% (checkPattern $1 `thenP` \p ->
returnP (Match [] [p] $2
- (GRHSs $3 $4 Nothing)) }
+ (GRHSs $3 $4 Nothing)) )}
ralt :: { [RdrNameGRHS] }
: '->' srcloc exp { [GRHS [ExprStmt $3 $2] $2] }
: varop { $1 }
| conop { $1 }
-qop :: { RdrNameHsExpr } -- used in sections
- : qvarop { HsVar $1 }
- | qconop { HsVar $1 }
+qop :: { RdrName {-HsExpr-} } -- used in sections
+ : qvarop { $1 }
+ | qconop { $1 }
qopm :: { RdrNameHsExpr } -- used in sections
: qvaropm { HsVar $1 }
tycon :: { RdrName }
: CONID { mkSrcUnqual tcClsName $1 }
+tyconop :: { RdrName }
+ : CONSYM { mkSrcUnqual tcClsName $1 }
+
qtycon :: { RdrName }
: tycon { $1 }
| QCONID { mkSrcQual tcClsName $1 }
extractHsTyRdrTyVars, extractHsTysRdrTyVars,
extractPatsTyVars,
extractRuleBndrsTyVars,
- extractHsCtxtRdrTyVars,
+ extractHsCtxtRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
mkHsNegApp, mkHsIntegralLit, mkHsFractionalLit, mkNPlusKPatIn,
cvBinds,
cvMonoBindsAndSigs,
cvTopDecls,
- cvValSig, cvClassOpSig, cvInstDeclSig
+ cvValSig, cvClassOpSig, cvInstDeclSig,
+ mkTyData
) where
#include "HsVersions.h"
import CmdLineOpts ( opt_NoImplicitPrelude )
import HsPat ( collectSigTysFromPats )
import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
- mkSuperDictSelOcc, mkDefaultMethodOcc,
- varName, dataName, tcName
+ mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
+ mkGenOcc2, varName, dataName, tcName
)
import PrelNames ( pRELUDE_Name, mkTupNameStr )
import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
import HsPragmas
import List ( nub )
import BasicTypes ( Boxity(..), RecFlag(..) )
+import Class ( DefMeth (..) )
+import Outputable
\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}
\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
+ = ClassDecl cxt cname tyvars fds sigs mbinds prags new_names loc
where
cls_occ = rdrNameOcc cname
data_occ = mkClassDataConOcc cls_occ
-- 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 = toClassDeclNameList (tname, dname, dwname, sc_sel_names)
+
+-- mkTyData :: ??
+mkTyData new_or_data context tname list_var list_con i maybe pragmas 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 pragmas src name1 name2
+
+mkClassOpSig (DefMeth x) op ty loc
+ = ClassOpSig op (Just (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
module PrelNames,
module MkId,
- builtinNames, -- Names of things whose *unique* must be known, but
- -- that is all. If something is in here, you know that
- -- if it's used at all then it's Name will be just as
- -- it is here, unique and all. Includes all the
-
-
+ wiredInNames, -- Names of wired in things
-- Primop RdrNames
#include "HsVersions.h"
-- friends:
-import MkId -- Ditto
import PrelNames -- Prelude module names
import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName )
import DataCon ( DataCon, dataConId, dataConWrapId )
-import TysPrim -- TYPES
-import TysWiredIn
+import MkId ( mkPrimOpId, wiredInIds )
+import MkId -- All of it, for re-export
+import TysPrim ( primTyCons )
+import TysWiredIn ( wiredInTyCons )
-- others:
import RdrName ( RdrName )
-import Name ( Name, mkKnownKeyGlobal, getName )
+import Name ( Name, getName )
import TyCon ( tyConDataConsIfAvailable, TyCon )
import Class ( Class, classKey )
import Type ( funTyCon )
@Classes@, the other to look up values.
\begin{code}
-builtinNames :: Bag Name
-builtinNames
- = unionManyBags
- [ -- Wired in TyCons
- unionManyBags (map getTyConNames wired_in_tycons)
+wiredInNames :: [Name]
+wiredInNames
+ = bagToList $ unionManyBags
+ [ -- Wired in TyCons
+ unionManyBags (map getTyConNames ([funTyCon] ++ primTyCons ++ wiredInTyCons))
-- Wired in Ids
, listToBag (map getName wiredInIds)
-- PrimOps
, listToBag (map (getName . mkPrimOpId) allThePrimOps)
-
- -- Other names with magic keys
- , listToBag (map mkKnownKeyGlobal knownKeyRdrNames)
- ]
+ ]
\end{code}
tagToEnumH_RDR = primOpRdrName TagToEnumOp
\end{code}
-%************************************************************************
-%* *
-\subsection{Wired in TyCons}
-%* *
-%************************************************************************
-
-\begin{code}
-wired_in_tycons = [funTyCon] ++
- prim_tycons ++
- tuple_tycons ++
- unboxed_tuple_tycons ++
- data_tycons
-
-prim_tycons
- = [ addrPrimTyCon
- , arrayPrimTyCon
- , byteArrayPrimTyCon
- , charPrimTyCon
- , doublePrimTyCon
- , floatPrimTyCon
- , intPrimTyCon
- , int64PrimTyCon
- , foreignObjPrimTyCon
- , bcoPrimTyCon
- , weakPrimTyCon
- , mutableArrayPrimTyCon
- , mutableByteArrayPrimTyCon
- , mVarPrimTyCon
- , mutVarPrimTyCon
- , realWorldTyCon
- , stablePtrPrimTyCon
- , stableNamePrimTyCon
- , statePrimTyCon
- , threadIdPrimTyCon
- , wordPrimTyCon
- , word64PrimTyCon
- ]
-
-tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..37] ]
-unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..37] ]
-
-data_tycons
- = [ addrTyCon
- , boolTyCon
- , charTyCon
- , doubleTyCon
- , floatTyCon
- , intTyCon
- , integerTyCon
- , listTyCon
- , wordTyCon
- ]
-\end{code}
-
%************************************************************************
%* *
\begin{code}
module PrelNames (
-
Unique, Uniquable(..), hasKey, -- Re-exported for convenience
- knownKeyRdrNames,
- mkTupNameStr, mkTupConRdrName,
-
- ------------------------------------------------------------
- -- Prelude modules
- pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE,
- pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL,
- ------------------------------------------------------------
- -- Module names (both Prelude and otherwise)
- pREL_GHC_Name, pRELUDE_Name, pREL_MAIN_Name, mAIN_Name,
+ -----------------------------------------------------------
+ module PrelNames, -- A huge bunch of (a) RdrNames, e.g. intTyCon_RDR
+ -- (b) Uniques e.g. intTyConKey
+ -- So many that we export them all
- ------------------------------------------------------------
- -- Original RdrNames for a few things
- main_RDR,
- deRefStablePtr_RDR, makeStablePtr_RDR,
- ioTyCon_RDR, ioDataCon_RDR, bindIO_RDR, returnIO_RDR,
- unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
- eqClass_RDR, foldr_RDR, build_RDR,
- ccallableClass_RDR, creturnableClass_RDR,
- monadClass_RDR, enumClass_RDR, ordClass_RDR,
- ratioDataCon_RDR, negate_RDR, assertErr_RDR,
- plusInteger_RDR, timesInteger_RDR, eqString_RDR,
-
- -- Plus a whole lot more needed only in TcGenDeriv
- eq_RDR, ne_RDR, not_RDR, compare_RDR, ge_RDR, le_RDR, gt_RDR,
- ltTag_RDR, eqTag_RDR, gtTag_RDR, getTag_RDR,
- and_RDR, true_RDR, false_RDR,
- succ_RDR, pred_RDR, toEnum_RDR, fromEnum_RDR,
- minBound_RDR, maxBound_RDR,
- enumFrom_RDR, enumFromThen_RDR, enumFromTo_RDR, enumFromThenTo_RDR,
- map_RDR, append_RDR, compose_RDR,
- plus_RDR, times_RDR, mkInt_RDR,
- error_RDR,
- range_RDR, inRange_RDR, index_RDR,
- readList___RDR, readList_RDR, readsPrec_RDR, lex_RDR, readParen_RDR,
- showList_RDR, showList___RDR, showsPrec_RDR, showString_RDR, showSpace_RDR, showParen_RDR,
+ -----------------------------------------------------------
+ knownKeyRdrNames,
+ mkTupNameStr, mkTupConRdrName,
------------------------------------------------------------
-- Goups of classes and types
derivingOccurrences, -- For a given class C, this tells what other
derivableClassKeys, -- things are needed as a result of a
-- deriving(C) clause
- numericTyKeys, cCallishTyKeys,
-
- ------------------------------------------------------------
- -- Keys
- absentErrorIdKey, addrDataConKey, addrPrimTyConKey, addrTyConKey,
- appendIdKey, arrayPrimTyConKey, assertIdKey, augmentIdKey,
- bcoPrimTyConKey, bindIOIdKey, boolTyConKey, boundedClassKey,
- boxedConKey, buildIdKey, byteArrayPrimTyConKey, byteArrayTyConKey,
- cCallableClassKey, cReturnableClassKey, charDataConKey,
- charPrimTyConKey, charTyConKey, concatIdKey, consDataConKey,
- deRefStablePtrIdKey, doubleDataConKey, doublePrimTyConKey,
- doubleTyConKey, enumClassKey, enumFromClassOpKey,
- enumFromThenClassOpKey, enumFromThenToClassOpKey,
- enumFromToClassOpKey, eqClassKey, eqClassOpKey, eqStringIdKey,
- errorIdKey, falseDataConKey, failMClassOpKey, filterIdKey,
- floatDataConKey, floatPrimTyConKey, floatTyConKey, floatingClassKey,
- foldlIdKey, foldrIdKey, foreignObjDataConKey, foreignObjPrimTyConKey,
- foreignObjTyConKey, fractionalClassKey, fromEnumClassOpKey,
- fromIntClassOpKey, fromIntegerClassOpKey, fromRationalClassOpKey,
- funTyConKey, functorClassKey, geClassOpKey, getTagIdKey,
- intDataConKey, intPrimTyConKey, intTyConKey, int8TyConKey,
- int16TyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey,
- smallIntegerDataConKey, largeIntegerDataConKey, integerMinusOneIdKey,
- integerPlusOneIdKey, integerPlusTwoIdKey, int2IntegerIdKey,
- integerTyConKey, integerZeroIdKey, integralClassKey,
- irrefutPatErrorIdKey, ixClassKey, listTyConKey, mainKey,
- makeStablePtrIdKey, mapIdKey, minusClassOpKey, monadClassKey,
- monadPlusClassKey, mutableArrayPrimTyConKey,
- mutableByteArrayPrimTyConKey, mutableByteArrayTyConKey,
- mutVarPrimTyConKey, nilDataConKey, noMethodBindingErrorIdKey,
- nonExhaustiveGuardsErrorIdKey, numClassKey, anyBoxConKey, ordClassKey,
- orderingTyConKey, otherwiseIdKey, parErrorIdKey, parIdKey,
- patErrorIdKey, plusIntegerIdKey, ratioDataConKey, ratioTyConKey,
- rationalTyConKey, readClassKey, realClassKey, realFloatClassKey,
- realFracClassKey, realWorldPrimIdKey, realWorldTyConKey,
- recConErrorIdKey, recSelErrIdKey, recUpdErrorIdKey, returnIOIdKey,
- returnMClassOpKey, runSTRepIdKey, showClassKey, ioTyConKey,
- ioDataConKey, stablePtrDataConKey, stablePtrPrimTyConKey,
- stablePtrTyConKey, stableNameDataConKey, stableNamePrimTyConKey,
- stableNameTyConKey, statePrimTyConKey, timesIntegerIdKey, typeConKey,
- kindConKey, boxityConKey, mVarPrimTyConKey, thenMClassOpKey,
- threadIdPrimTyConKey, toEnumClassOpKey, traceIdKey, trueDataConKey,
- unboundKey, unboxedConKey, unpackCStringUtf8IdKey,
- unpackCStringAppendIdKey, unpackCStringFoldrIdKey, unpackCStringIdKey,
- unsafeCoerceIdKey, ushowListIdKey, weakPrimTyConKey, wordDataConKey,
- wordPrimTyConKey, wordTyConKey, word8TyConKey, word16TyConKey,
- word32TyConKey, word64PrimTyConKey, word64TyConKey, zipIdKey
+ numericTyKeys, cCallishTyKeys
) where
%************************************************************************
This section tells what the compiler knows about the
-assocation of names with uniques
+assocation of names with uniques. These ones are the *non* wired-in ones.
+The wired in ones are defined in TysWiredIn etc.
\begin{code}
knownKeyRdrNames :: [(RdrName, Unique)]
\begin{code}
main_RDR = varQual mAIN_Name SLIT("main")
-ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO")
-ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO")
-bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO")
-returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO")
-
+-- Stuff from PrelGHC
+funTyCon_RDR = tcQual pREL_GHC_Name SLIT("(->)")
+ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable")
+creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable")
-rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational")
-ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio")
-ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%")
-
-byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray")
-mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray")
-
-foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj")
-bcoPrimTyCon_RDR = tcQual pREL_BASE_Name SLIT("BCO#")
-stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr")
-stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr")
-deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr")
-makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr")
-
--- Random PrelBase data types and constructors
+-- PrelBase data types and constructors
+charTyCon_RDR = tcQual pREL_BASE_Name SLIT("Char")
+charDataCon_RDR = dataQual pREL_BASE_Name SLIT("C#")
intTyCon_RDR = tcQual pREL_BASE_Name SLIT("Int")
-orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering")
mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#")
+orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering")
+boolTyCon_RDR = tcQual pREL_BASE_Name SLIT("Bool")
false_RDR = dataQual pREL_BASE_Name SLIT("False")
true_RDR = dataQual pREL_BASE_Name SLIT("True")
+listTyCon_RDR = tcQual pREL_BASE_Name SLIT("[]")
+nil_RDR = dataQual pREL_BASE_Name SLIT("[]")
+cons_RDR = dataQual pREL_BASE_Name SLIT(":")
+
+-- Generics
+crossTyCon_RDR = tcQual pREL_BASE_Name SLIT(":*:")
+crossDataCon_RDR = dataQual pREL_BASE_Name SLIT(":*:")
+plusTyCon_RDR = tcQual pREL_BASE_Name SLIT(":+:")
+inlDataCon_RDR = dataQual pREL_BASE_Name SLIT("Inl")
+inrDataCon_RDR = dataQual pREL_BASE_Name SLIT("Inr")
+genUnitTyCon_RDR = tcQual pREL_BASE_Name SLIT("Unit")
+genUnitDataCon_RDR = dataQual pREL_BASE_Name SLIT("Unit")
-- Random PrelBase functions
otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise")
unpackCStringUtf8_RDR = varQual pREL_BASE_Name SLIT("unpackCStringUtf8#")
-- Classes Eq and Ord
-eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq")
-ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord")
-eq_RDR = varQual pREL_BASE_Name SLIT("==")
-ne_RDR = varQual pREL_BASE_Name SLIT("/=")
-le_RDR = varQual pREL_BASE_Name SLIT("<=")
-lt_RDR = varQual pREL_BASE_Name SLIT("<")
-ge_RDR = varQual pREL_BASE_Name SLIT(">=")
-gt_RDR = varQual pREL_BASE_Name SLIT(">")
+eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq")
+ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord")
+eq_RDR = varQual pREL_BASE_Name SLIT("==")
+ne_RDR = varQual pREL_BASE_Name SLIT("/=")
+le_RDR = varQual pREL_BASE_Name SLIT("<=")
+lt_RDR = varQual pREL_BASE_Name SLIT("<")
+ge_RDR = varQual pREL_BASE_Name SLIT(">=")
+gt_RDR = varQual pREL_BASE_Name SLIT(">")
ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT")
eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ")
gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT")
-max_RDR = varQual pREL_BASE_Name SLIT("max")
-min_RDR = varQual pREL_BASE_Name SLIT("min")
-compare_RDR = varQual pREL_BASE_Name SLIT("compare")
+max_RDR = varQual pREL_BASE_Name SLIT("max")
+min_RDR = varQual pREL_BASE_Name SLIT("min")
+compare_RDR = varQual pREL_BASE_Name SLIT("compare")
-- Class Monad
monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad")
failM_RDR = varQual pREL_BASE_Name SLIT("fail")
-- Class Functor
-functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor")
+functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor")
-- Class Show
showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show")
showString_RDR = varQual pREL_SHOW_Name SLIT("showString")
showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen")
-
-- Class Read
readClass_RDR = clsQual pREL_READ_Name SLIT("Read")
readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec")
readList___RDR = varQual pREL_READ_Name SLIT("readList__")
--- Class Num
+-- Module PrelNum
numClass_RDR = clsQual pREL_NUM_Name SLIT("Num")
fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt")
fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger")
times_RDR = varQual pREL_NUM_Name SLIT("*")
plusInteger_RDR = varQual pREL_NUM_Name SLIT("plusInteger")
timesInteger_RDR = varQual pREL_NUM_Name SLIT("timesInteger")
+integerTyCon_RDR = tcQual pREL_NUM_Name SLIT("Integer")
+smallIntegerDataCon_RDR = dataQual pREL_NUM_Name SLIT("S#")
+largeIntegerDataCon_RDR = dataQual pREL_NUM_Name SLIT("J#")
--- Other numberic classes
-realClass_RDR = clsQual pREL_REAL_Name SLIT("Real")
-integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral")
-realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac")
-fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional")
-fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational")
-
-floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating")
-realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat")
+-- PrelReal types and classes
+rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational")
+ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio")
+ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%")
+realClass_RDR = clsQual pREL_REAL_Name SLIT("Real")
+integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral")
+realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac")
+fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional")
+fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational")
+
+-- PrelFloat classes
+floatTyCon_RDR = tcQual pREL_FLOAT_Name SLIT("Float")
+floatDataCon_RDR = dataQual pREL_FLOAT_Name SLIT("F#")
+doubleTyCon_RDR = tcQual pREL_FLOAT_Name SLIT("Double")
+doubleDataCon_RDR = dataQual pREL_FLOAT_Name SLIT("D#")
+floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating")
+realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat")
-- Class Ix
ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix")
index_RDR = varQual pREL_ARR_Name SLIT("index")
inRange_RDR = varQual pREL_ARR_Name SLIT("inRange")
--- Class CCallable and CReturnable
-ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable")
-creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable")
-
-- Class Enum
enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum")
succ_RDR = varQual pREL_ENUM_Name SLIT("succ")
filter_RDR = varQual pREL_LIST_Name SLIT("filter")
zip_RDR = varQual pREL_LIST_Name SLIT("zip")
+-- IOBase things
+ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO")
+ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO")
+bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO")
+returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO")
+
+-- Int, Word, and Addr things
int8TyCon_RDR = tcQual iNT_Name SLIT("Int8")
int16TyCon_RDR = tcQual iNT_Name SLIT("Int16")
int32TyCon_RDR = tcQual iNT_Name SLIT("Int32")
int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64")
-word8TyCon_RDR = tcQual wORD_Name SLIT("Word8")
-word16TyCon_RDR = tcQual wORD_Name SLIT("Word16")
-word32TyCon_RDR = tcQual wORD_Name SLIT("Word32")
-word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64")
+wordTyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word")
+wordDataCon_RDR = dataQual pREL_ADDR_Name SLIT("W#")
+word8TyCon_RDR = tcQual wORD_Name SLIT("Word8")
+word16TyCon_RDR = tcQual wORD_Name SLIT("Word16")
+word32TyCon_RDR = tcQual wORD_Name SLIT("Word32")
+word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64")
+
+addrTyCon_RDR = tcQual pREL_ADDR_Name SLIT("Addr")
+addrDataCon_RDR = dataQual pREL_ADDR_Name SLIT("A#")
+
+
+-- Byte array types
+byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray")
+mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray")
+
+-- Forign objects and weak pointers
+foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj")
+foreignObjDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("ForeignObj")
+bcoPrimTyCon_RDR = tcQual pREL_BASE_Name SLIT("BCO#")
+stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr")
+stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr")
+deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr")
+makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr")
error_RDR = varQual pREL_ERR_Name SLIT("error")
assert_RDR = varQual pREL_GHC_Name SLIT("assert")
getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#")
assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError")
runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep")
+
\end{code}
typeConKey = mkPreludeTyConUnique 69
threadIdPrimTyConKey = mkPreludeTyConUnique 70
bcoPrimTyConKey = mkPreludeTyConUnique 71
+
+-- Generic Type Constructors
+crossTyConKey = mkPreludeTyConUnique 72
+plusTyConKey = mkPreludeTyConUnique 73
+genUnitTyConKey = mkPreludeTyConUnique 74
\end{code}
%************************************************************************
trueDataConKey = mkPreludeDataConUnique 14
wordDataConKey = mkPreludeDataConUnique 15
ioDataConKey = mkPreludeDataConUnique 16
+
+-- Generic data constructors
+crossDataConKey = mkPreludeDataConUnique 17
+inlDataConKey = mkPreludeDataConUnique 18
+inrDataConKey = mkPreludeDataConUnique 19
+genUnitDataConKey = mkPreludeDataConUnique 20
\end{code}
%************************************************************************
%************************************************************************
%* *
+\subsection{Standard groups of types}
+%* *
+%************************************************************************
+
+\begin{code}
+numericTyKeys =
+ [ addrTyConKey
+ , wordTyConKey
+ , intTyConKey
+ , integerTyConKey
+ , doubleTyConKey
+ , floatTyConKey
+ ]
+
+ -- Renamer always imports these data decls replete with constructors
+ -- so that desugarer can always see their constructors. Ugh!
+cCallishTyKeys =
+ [ addrTyConKey
+ , wordTyConKey
+ , byteArrayTyConKey
+ , mutableByteArrayTyConKey
+ , foreignObjTyConKey
+ , stablePtrTyConKey
+ , int8TyConKey
+ , int16TyConKey
+ , int32TyConKey
+ , int64TyConKey
+ , word8TyConKey
+ , word16TyConKey
+ , word32TyConKey
+ , word64TyConKey
+ ]
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[Class-std-groups]{Standard groups of Prelude classes}
%* *
%************************************************************************
-- the strictness analyser needs to know about numeric types
-- (see SaAbsInt.lhs)
-numericTyKeys =
- [ addrTyConKey
- , wordTyConKey
- , intTyConKey
- , integerTyConKey
- , doubleTyConKey
- , floatTyConKey
- ]
-
needsDataDeclCtxtClassKeys = -- see comments in TcDeriv
[ readClassKey
]
, cReturnableClassKey
]
- -- Renamer always imports these data decls replete with constructors
- -- so that desugarer can always see their constructors. Ugh!
-cCallishTyKeys =
- [ addrTyConKey
- , wordTyConKey
- , byteArrayTyConKey
- , mutableByteArrayTyConKey
- , foreignObjTyConKey
- , stablePtrTyConKey
- , int8TyConKey
- , int16TyConKey
- , int32TyConKey
- , int64TyConKey
- , word8TyConKey
- , word16TyConKey
- , word32TyConKey
- , word64TyConKey
- ]
-
standardClassKeys
= derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
--
alphaTy, betaTy, gammaTy, deltaTy,
openAlphaTy, openAlphaTyVar, openAlphaTyVars,
+ primTyCons,
+
charPrimTyCon, charPrimTy,
intPrimTyCon, intPrimTy,
wordPrimTyCon, wordPrimTy,
import Var ( TyVar, mkSysTyVar )
import Name ( mkWiredInTyConName )
+import OccName ( mkSrcOccFS, tcName )
import PrimRep ( PrimRep(..), isFollowableRep )
import TyCon ( mkPrimTyCon, TyCon, ArgVrcs )
import Type ( Type,
mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
unboxedTypeKind, boxedTypeKind, openTypeKind, mkArrowKinds
)
-import Unique ( mkAlphaTyVarUnique )
+import Unique ( Unique, mkAlphaTyVarUnique )
import PrelNames
import Outputable
\end{code}
+%************************************************************************
+%* *
+\subsection{Primitive type constructors}
+%* *
+%************************************************************************
+
+\begin{code}
+primTyCons :: [TyCon]
+primTyCons
+ = [ addrPrimTyCon
+ , arrayPrimTyCon
+ , byteArrayPrimTyCon
+ , charPrimTyCon
+ , doublePrimTyCon
+ , floatPrimTyCon
+ , intPrimTyCon
+ , int64PrimTyCon
+ , foreignObjPrimTyCon
+ , bcoPrimTyCon
+ , weakPrimTyCon
+ , mutableArrayPrimTyCon
+ , mutableByteArrayPrimTyCon
+ , mVarPrimTyCon
+ , mutVarPrimTyCon
+ , realWorldTyCon
+ , stablePtrPrimTyCon
+ , stableNamePrimTyCon
+ , statePrimTyCon
+ , threadIdPrimTyCon
+ , wordPrimTyCon
+ , word64PrimTyCon
+ ]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Support code}
+%* *
+%************************************************************************
+
\begin{code}
alphaTyVars :: [TyVar]
alphaTyVars = [ mkSysTyVar u boxedTypeKind
vrcsZP = [vrcZero,vrcPos]
\end{code}
+
%************************************************************************
%* *
\subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)}
pcPrimTyCon key str arity arg_vrcs rep
= the_tycon
where
- name = mkWiredInTyConName key pREL_GHC str the_tycon
+ name = mkWiredInTyConName key pREL_GHC (mkSrcOccFS tcName str) the_tycon
the_tycon = mkPrimTyCon name kind arity arg_vrcs rep
kind = mkArrowKinds (take arity (repeat boxedTypeKind)) result_kind
result_kind | isFollowableRep rep = boxedTypeKind -- Represented by a GC-ish ptr
\begin{code}
module TysWiredIn (
+ wiredInTyCons, genericTyCons,
+
addrDataCon,
addrTy,
addrTyCon,
unboxedSingletonTyCon, unboxedSingletonDataCon,
unboxedPairTyCon, unboxedPairDataCon,
+ -- Generics
+ genUnitTyCon, genUnitDataCon,
+ plusTyCon, inrDataCon, inlDataCon,
+ crossTyCon, crossDataCon,
+
stablePtrTyCon,
stringTy,
trueDataCon, trueDataConId,
#include "HsVersions.h"
import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId )
+import {-# SOURCE #-} Generics( mkTyConGenInfo )
-- friends:
import PrelNames
-- others:
import Constants ( mAX_TUPLE_SIZE )
import Module ( Module, mkPrelModule )
-import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, mkWorkerOcc, dataName )
+import Name ( mkWiredInTyConName, mkWiredInIdName, nameOccName )
+import OccName ( mkSrcOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
+import RdrName ( RdrName, mkPreludeQual, rdrNameOcc, rdrNameModule )
import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId )
import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, tyConDataCons,
- mkAlgTyCon, mkSynTyCon, mkTupleTyCon, isUnLiftedTyCon
+ mkSynTyCon, mkTupleTyCon,
+ isUnLiftedTyCon, mkAlgTyConRep,tyConName
)
-import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed )
+
+import BasicTypes ( Arity, RecFlag(..), EP(..), Boxity(..), isBoxed )
+
import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
- mkFunTy, mkFunTys,
- splitTyConApp_maybe, repType,
+ mkFunTy, mkFunTys,
+ splitTyConApp_maybe, repType, mkTyVarTy,
TauType, ClassContext )
import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique )
import PrelNames
import CmdLineOpts ( opt_GlasgowExts )
import Array
+import Maybe ( fromJust )
+import FiniteMap ( lookupFM )
alpha_tyvar = [alphaTyVar]
alpha_ty = [alphaTy]
alpha_beta_tyvars = [alphaTyVar, betaTyVar]
+\end{code}
-pcRecDataTyCon, pcNonRecDataTyCon
- :: Unique{-TyConKey-} -> Module -> FAST_STRING
- -> [TyVar] -> ArgVrcs -> [DataCon] -> TyCon
-pcRecDataTyCon = pcTyCon DataTyCon Recursive
-pcNonRecDataTyCon = pcTyCon DataTyCon NonRecursive
+%************************************************************************
+%* *
+\subsection{Wired in type constructors}
+%* *
+%************************************************************************
-pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons
- = tycon
- where
- tycon = mkAlgTyCon name kind
- tyvars
- [] -- No context
- argvrcs
- cons
- (length cons)
- [] -- No derivings
- new_or_data
- is_rec
+\begin{code}
+wiredInTyCons :: [TyCon]
+wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons
+
+data_tycons = genericTyCons ++
+ [ addrTyCon
+ , boolTyCon
+ , charTyCon
+ , doubleTyCon
+ , floatTyCon
+ , intTyCon
+ , integerTyCon
+ , listTyCon
+ , wordTyCon
+ ]
+
+genericTyCons :: [TyCon]
+genericTyCons = [ plusTyCon, crossTyCon, genUnitTyCon ]
+
+
+tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..37] ]
+unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..37] ]
+\end{code}
- name = mkWiredInTyConName key mod str tycon
- kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind
-pcSynTyCon key mod str kind arity tyvars expansion argvrcs -- this fun never used!
+%************************************************************************
+%* *
+\subsection{mkWiredInTyCon}
+%* *
+%************************************************************************
+
+\begin{code}
+pcNonRecDataTyCon = pcTyCon DataTyCon NonRecursive
+pcRecDataTyCon = pcTyCon DataTyCon Recursive
+
+pcTyCon new_or_data is_rec key rdr_name tyvars argvrcs cons
= tycon
where
- tycon = mkSynTyCon name kind arity tyvars expansion argvrcs
- name = mkWiredInTyConName key mod str tycon
-
-pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING
- -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon
+ tycon = mkAlgTyConRep name kind
+ tyvars
+ [] -- No context
+ argvrcs
+ cons
+ (length cons)
+ [] -- No derivings
+ new_or_data
+ is_rec
+ gen_info
+
+ mod = mkPrelModule (rdrNameModule rdr_name)
+ occ = rdrNameOcc rdr_name
+ name = mkWiredInTyConName key mod occ tycon
+ kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind
+ gen_info = mk_tc_gen_info mod key name tycon
+
+pcDataCon :: Unique -- DataConKey
+ -> RdrName -- Qualified
+ -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon
-- The unique is the first of two free uniques;
--- the first is used for the datacon itself and the worker;
+-- the first is used for the datacon itself and the worker;
-- the second is used for the wrapper.
-pcDataCon wrap_key mod str tyvars context arg_tys tycon
+
+pcDataCon wrap_key rdr_name tyvars context arg_tys tycon
= data_con
where
- data_con = mkDataCon wrap_name
- [ NotMarkedStrict | a <- arg_tys ]
- [ {- no labelled fields -} ]
- tyvars context [] [] arg_tys tycon work_id wrap_id
+ mod = mkPrelModule (rdrNameModule rdr_name)
+ wrap_occ = rdrNameOcc rdr_name
+
+ data_con = mkDataCon wrap_name
+ [ NotMarkedStrict | a <- arg_tys ]
+ [ {- no labelled fields -} ]
+ tyvars context [] [] arg_tys tycon work_id wrap_id
work_occ = mkWorkerOcc wrap_occ
work_key = incrUnique wrap_key
work_name = mkWiredInIdName work_key mod work_occ work_id
work_id = mkDataConId work_name data_con
-
- wrap_occ = mkSrcOccFS dataName str
+
wrap_name = mkWiredInIdName wrap_key mod wrap_occ wrap_id
wrap_id = mkDataConWrapId data_con
\end{code}
mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
mk_tuple boxity arity = (tycon, tuple_con)
where
- tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity
- tc_name = mkWiredInTyConName tc_uniq mod name_str tycon
+ tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info
+ tc_name = mkWiredInTyConName tc_uniq mod (mkSrcOccFS tcName name_str) tycon
tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind
res_kind | isBoxed boxity = boxedTypeKind
| otherwise = unboxedTypeKind
tyvars | isBoxed boxity = take arity alphaTyVars
| otherwise = take arity openAlphaTyVars
- tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon
+ tuple_con = pcDataCon dc_uniq rdr_name tyvars [] tyvar_tys tycon
tyvar_tys = mkTyVarTys tyvars
(mod_name, name_str) = mkTupNameStr boxity arity
+ rdr_name = mkPreludeQual dataName mod_name name_str
tc_uniq = mkTupleTyConUnique boxity arity
dc_uniq = mkTupleDataConUnique boxity arity
mod = mkPrelModule mod_name
+ gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon
+
+mk_tc_gen_info mod tc_uniq tc_name tycon
+ = gen_info
+ where
+ tc_occ_name = nameOccName tc_name
+ occ_name1 = mkGenOcc1 tc_occ_name
+ occ_name2 = mkGenOcc2 tc_occ_name
+ fn1_key = incrUnique tc_uniq
+ fn2_key = incrUnique fn1_key
+ name1 = mkWiredInIdName fn1_key mod occ_name1 id1
+ name2 = mkWiredInIdName fn2_key mod occ_name2 id2
+ gen_info = mkTyConGenInfo tycon name1 name2
+ Just (EP id1 id2) = gen_info
unitTyCon = tupleTyCon Boxed 0
unitDataConId = dataConId (head (tyConDataCons unitTyCon))
\begin{code}
charTy = mkTyConTy charTyCon
-charTyCon = pcNonRecDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [] [charDataCon]
-charDataCon = pcDataCon charDataConKey pREL_BASE SLIT("C#") [] [] [charPrimTy] charTyCon
+charTyCon = pcNonRecDataTyCon charTyConKey charTyCon_RDR [] [] [charDataCon]
+charDataCon = pcDataCon charDataConKey charDataCon_RDR [] [] [charPrimTy] charTyCon
stringTy = mkListTy charTy -- convenience only
\end{code}
\begin{code}
intTy = mkTyConTy intTyCon
-intTyCon = pcNonRecDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [] [intDataCon]
-intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon
+intTyCon = pcNonRecDataTyCon intTyConKey intTyCon_RDR [] [] [intDataCon]
+intDataCon = pcDataCon intDataConKey mkInt_RDR [] [] [intPrimTy] intTyCon
isIntTy :: Type -> Bool
isIntTy = isTyCon intTyConKey
wordTy = mkTyConTy wordTyCon
-wordTyCon = pcNonRecDataTyCon wordTyConKey pREL_ADDR SLIT("Word") [] [] [wordDataCon]
-wordDataCon = pcDataCon wordDataConKey pREL_ADDR SLIT("W#") [] [] [wordPrimTy] wordTyCon
+wordTyCon = pcNonRecDataTyCon wordTyConKey wordTyCon_RDR [] [] [wordDataCon]
+wordDataCon = pcDataCon wordDataConKey wordDataCon_RDR [] [] [wordPrimTy] wordTyCon
\end{code}
\begin{code}
addrTy = mkTyConTy addrTyCon
-addrTyCon = pcNonRecDataTyCon addrTyConKey pREL_ADDR SLIT("Addr") [] [] [addrDataCon]
-addrDataCon = pcDataCon addrDataConKey pREL_ADDR SLIT("A#") [] [] [addrPrimTy] addrTyCon
+addrTyCon = pcNonRecDataTyCon addrTyConKey addrTyCon_RDR [] [] [addrDataCon]
+addrDataCon = pcDataCon addrDataConKey addrDataCon_RDR [] [] [addrPrimTy] addrTyCon
isAddrTy :: Type -> Bool
isAddrTy = isTyCon addrTyConKey
\begin{code}
floatTy = mkTyConTy floatTyCon
-floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_FLOAT SLIT("Float") [] [] [floatDataCon]
-floatDataCon = pcDataCon floatDataConKey pREL_FLOAT SLIT("F#") [] [] [floatPrimTy] floatTyCon
+floatTyCon = pcNonRecDataTyCon floatTyConKey floatTyCon_RDR [] [] [floatDataCon]
+floatDataCon = pcDataCon floatDataConKey floatDataCon_RDR [] [] [floatPrimTy] floatTyCon
isFloatTy :: Type -> Bool
isFloatTy = isTyCon floatTyConKey
isDoubleTy :: Type -> Bool
isDoubleTy = isTyCon doubleTyConKey
-doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_FLOAT SLIT("Double") [] [] [doubleDataCon]
-doubleDataCon = pcDataCon doubleDataConKey pREL_FLOAT SLIT("D#") [] [] [doublePrimTy] doubleTyCon
+doubleTyCon = pcNonRecDataTyCon doubleTyConKey doubleTyCon_RDR [] [] [doubleDataCon]
+doubleDataCon = pcDataCon doubleDataConKey doubleDataCon_RDR [] [] [doublePrimTy] doubleTyCon
\end{code}
\begin{code}
stablePtrTyCon
- = pcNonRecDataTyCon stablePtrTyConKey pREL_STABLE SLIT("StablePtr")
+ = pcNonRecDataTyCon stablePtrTyConKey stablePtrTyCon_RDR
alpha_tyvar [(True,False)] [stablePtrDataCon]
where
stablePtrDataCon
- = pcDataCon stablePtrDataConKey pREL_STABLE SLIT("StablePtr")
+ = pcDataCon stablePtrDataConKey stablePtrDataCon_RDR
alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon
\end{code}
\begin{code}
foreignObjTyCon
- = pcNonRecDataTyCon foreignObjTyConKey pREL_IO_BASE SLIT("ForeignObj")
+ = pcNonRecDataTyCon foreignObjTyConKey foreignObjTyCon_RDR
[] [] [foreignObjDataCon]
where
foreignObjDataCon
- = pcDataCon foreignObjDataConKey pREL_IO_BASE SLIT("ForeignObj")
+ = pcDataCon foreignObjDataConKey foreignObjDataCon_RDR
[] [] [foreignObjPrimTy] foreignObjTyCon
isForeignObjTy :: Type -> Bool
integerTy :: Type
integerTy = mkTyConTy integerTyCon
-integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_NUM SLIT("Integer")
+integerTyCon = pcNonRecDataTyCon integerTyConKey integerTyCon_RDR
[] [] [smallIntegerDataCon, largeIntegerDataCon]
-smallIntegerDataCon = pcDataCon smallIntegerDataConKey pREL_NUM SLIT("S#")
+smallIntegerDataCon = pcDataCon smallIntegerDataConKey smallIntegerDataCon_RDR
[] [] [intPrimTy] integerTyCon
-largeIntegerDataCon = pcDataCon largeIntegerDataConKey pREL_NUM SLIT("J#")
+largeIntegerDataCon = pcDataCon largeIntegerDataConKey largeIntegerDataCon_RDR
[] [] [intPrimTy, byteArrayPrimTy] integerTyCon
boolTy = mkTyConTy boolTyCon
boolTyCon = pcTyCon EnumTyCon NonRecursive boolTyConKey
- pREL_BASE SLIT("Bool") [] [] [falseDataCon, trueDataCon]
+ boolTyCon_RDR [] [] [falseDataCon, trueDataCon]
-falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon
-trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon
+falseDataCon = pcDataCon falseDataConKey false_RDR [] [] [] boolTyCon
+trueDataCon = pcDataCon trueDataConKey true_RDR [] [] [] boolTyCon
falseDataConId = dataConId falseDataCon
trueDataConId = dataConId trueDataCon
alphaListTy = mkSigmaTy alpha_tyvar [] (mkTyConApp listTyCon alpha_ty)
-listTyCon = pcRecDataTyCon listTyConKey pREL_BASE SLIT("[]")
+listTyCon = pcRecDataTyCon listTyConKey listTyCon_RDR
alpha_tyvar [(True,False)] [nilDataCon, consDataCon]
-nilDataCon = pcDataCon nilDataConKey pREL_BASE SLIT("[]") alpha_tyvar [] [] listTyCon
-consDataCon = pcDataCon consDataConKey pREL_BASE SLIT(":")
+nilDataCon = pcDataCon nilDataConKey nil_RDR alpha_tyvar [] [] listTyCon
+consDataCon = pcDataCon consDataConKey cons_RDR
alpha_tyvar [] [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
-- Interesting: polymorphic recursion would help here.
-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
unitTy = mkTupleTy Boxed 0 []
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Wired In Type Constructors for Representation Types}
+%* *
+%************************************************************************
+
+The following code defines the wired in datatypes cross, plus, unit
+and c_of needed for the generic methods.
+
+Ok, so the basic story is that for each type constructor I need to
+create 2 things - a TyCon and a DataCon and then we are basically
+ok. There are going to be no arguments passed to these functions
+because -well- there is nothing to pass to these functions.
+
+\begin{code}
+crossTyCon :: TyCon
+crossTyCon = pcNonRecDataTyCon crossTyConKey crossTyCon_RDR alpha_beta_tyvars [] [crossDataCon]
+
+crossDataCon :: DataCon
+crossDataCon = pcDataCon crossDataConKey crossDataCon_RDR alpha_beta_tyvars [] [alphaTy, betaTy] crossTyCon
+
+plusTyCon :: TyCon
+plusTyCon = pcNonRecDataTyCon plusTyConKey plusTyCon_RDR alpha_beta_tyvars [] [inlDataCon, inrDataCon]
+
+inlDataCon, inrDataCon :: DataCon
+inlDataCon = pcDataCon inlDataConKey inlDataCon_RDR alpha_beta_tyvars [] [alphaTy] plusTyCon
+inrDataCon = pcDataCon inrDataConKey inrDataCon_RDR alpha_beta_tyvars [] [betaTy] plusTyCon
+
+genUnitTyCon :: TyCon -- The "1" type constructor for generics
+genUnitTyCon = pcNonRecDataTyCon genUnitTyConKey genUnitTyCon_RDR [] [] [genUnitDataCon]
+
+genUnitDataCon :: DataCon
+genUnitDataCon = pcDataCon genUnitDataConKey genUnitDataCon_RDR [] [] [] genUnitTyCon
+\end{code}
+
+
+
+
+
import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply )
import Unique ( Unique )
import VarSet
-import Util ( removeDups )
+import ListSetOps ( removeDups )
import Outputable
infixr 9 `thenMM`, `thenMM_`
import CmdLineOpts ( opt_InPackage )
import Outputable
import List ( insert )
+import Class ( DefMeth (..) )
import GlaExts
import FastString ( tailFS )
'{' { ITocurly } -- special symbols
'}' { ITccurly }
+ '{|' { ITocurlybar } -- special symbols
+ '|}' { ITccurlybar } -- special symbols
'[' { ITobrack }
']' { ITcbrack }
'(' { IToparen }
| csig ';' csigs1 { $1 : $3 }
csig :: { RdrNameSig }
-csig : src_loc var_name '::' type { mkClassOpSig False $2 $4 $1 }
- | src_loc var_name '=' '::' type { mkClassOpSig True $2 $5 $1 }
+csig : src_loc var_name '::' type { mkClassOpSig NoDefMeth $2 $4 $1 }
+ | src_loc var_name '=' '::' type { mkClassOpSig (DefMeth (error "DefMeth") )
+ $2 $5 $1 }
+ | src_loc var_name ';' '::' type { mkClassOpSig GenDefMeth $2 $5 $1 }
--------------------------------------------------------------------------
| src_loc 'type' tc_name tv_bndrs '=' type
{ TyClD (TySynonym $3 $4 $6 $1) }
| src_loc 'data' opt_decl_context tc_name tv_bndrs constrs
- { TyClD (TyData DataType $3 $4 $5 $6 (length $6) Nothing noDataPragmas $1) }
+ { TyClD (mkTyData DataType $3 $4 $5 $6 (length $6) Nothing noDataPragmas $1) }
| src_loc 'newtype' opt_decl_context tc_name tv_bndrs newtype_constr
- { TyClD (TyData NewType $3 $4 $5 $6 1 Nothing noDataPragmas $1) }
+ { TyClD (mkTyData NewType $3 $4 $5 $6 1 Nothing noDataPragmas $1) }
| src_loc 'class' opt_decl_context tc_name tv_bndrs fds csigs
{ TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds
noClassPragmas $1) }
-- Virtually every program has error messages in it somewhere
string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR]
- get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _))
+ get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _ _))
= concat (map get_deriv deriv_classes)
get other = []
ASSERT( isEmptyFVs fvs )
returnRn decls1
-stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc))
- = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc))
+stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc name1 name2))
+ = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc
+ name1 name2))
-- Nuke the context and constructors
-- But retain the *number* of constructors!
-- Also the tvs will have kinds on them.
getGates source_fvs (SigD (IfaceSig _ ty _ _))
= extractHsTyNames ty
-getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _))
+getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ ))
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
(hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
-getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _))
+getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _ _))
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
(hsTyVarNames tvs)
`addOneToNameSet` tycon
getFixities acc (FixD fix)
= fix_decl acc fix
- getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _))
+ getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ ))
= foldlRn fix_decl acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too.
getFixities acc other_decl
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn,
lookupGlobalOccRn, lookupSigOccRn,
- warnUnusedLocalBinds, mapFvRn,
+ warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV
)
import CmdLineOpts ( opt_WarnMissingSigs )
import Digraph ( stronglyConnComp, SCC(..) )
import Name ( OccName, Name, nameOccName, mkUnboundName, isUnboundName )
import NameSet
-import RdrName ( RdrName, rdrNameOcc )
+import RdrName ( RdrName, rdrNameOcc )
import BasicTypes ( RecFlag(..) )
import List ( partition )
import Bag ( bagToList )
rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) ->
returnRn (final_binds, bind_fvs `plusFV` sig_fvs)
where
- binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
+ binder_rdr_names = collectMonoBinders mbinds
\end{code}
%************************************************************************
warnUnusedLocalBinds unused_binders `thenRn_`
returnRn (result, delListFromNameSet all_fvs new_mbinders)
where
- mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
+ mbinders_w_srclocs = collectLocatedMonoBinders mbinds
\end{code}
a binder.
\begin{code}
-rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars)
+rnMethodBinds :: [Name] -- Names for generic type variables
+ -> RdrNameMonoBinds
+ -> RnMS (RenamedMonoBinds, FreeVars)
-rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
+rnMethodBinds gen_tyvars EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
-rnMethodBinds (AndMonoBinds mb1 mb2)
- = rnMethodBinds mb1 `thenRn` \ (mb1', fvs1) ->
- rnMethodBinds mb2 `thenRn` \ (mb2', fvs2) ->
+rnMethodBinds gen_tyvars (AndMonoBinds mb1 mb2)
+ = rnMethodBinds gen_tyvars mb1 `thenRn` \ (mb1', fvs1) ->
+ rnMethodBinds gen_tyvars mb2 `thenRn` \ (mb2', fvs2) ->
returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)
-rnMethodBinds (FunMonoBind name inf matches locn)
+rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn)
= pushSrcLocRn locn $
lookupGlobalOccRn name `thenRn` \ sel_name ->
-- We use the selector name as the binder
- mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) ->
+ mapFvRn rn_match matches `thenRn` \ (new_matches, fvs) ->
mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_`
returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name)
+ where
+ -- Gruesome; bring into scope the correct members of the generic type variables
+ -- See comments in RnSource.rnDecl(ClassDecl)
+ rn_match match@(Match _ (TypePatIn ty : _) _ _)
+ = extendTyVarEnvFVRn gen_tvs (rnMatch match)
+ where
+ tvs = map rdrNameOcc (extractHsTyRdrNames ty)
+ gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs]
+
+ rn_match match = rnMatch match
+
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
+rnMethodBinds gen_tyvars mbind@(PatMonoBind other_pat _ locn)
= pushSrcLocRn locn $
failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)
\end{code}
-- Doesn't seem worth much trouble to sort this.
renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars)
-
+-- ClassOpSig is renamed elsewhere.
renameSig (Sig v ty src_loc)
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
import OccName ( OccName, occNameUserString, occNameFlavour )
import Module ( ModuleName, moduleName, mkVanillaModule, pprModuleName )
import FiniteMap
+import Unique ( Unique )
import UniqSupply
import SrcLoc ( SrcLoc )
import Outputable
-import Util ( removeDups, equivClasses, thenCmp, sortLt )
+import ListSetOps ( removeDups, equivClasses )
+import Util ( thenCmp, sortLt )
import List ( nub )
\end{code}
%*********************************************************
\begin{code}
+newLocalsRn :: (Unique -> OccName -> SrcLoc -> Name)
+ -> [(RdrName,SrcLoc)]
+ -> RnMS [Name]
+newLocalsRn mk_name rdr_names_w_loc
+ = getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
+ let
+ n = length rdr_names_w_loc
+ (us', us1) = splitUniqSupply us
+ uniqs = uniqsFromSupply n us1
+ names = [ mk_name uniq (rdrNameOcc rdr_name) loc
+ | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
+ ]
+ in
+ setNameSupplyRn (us', cache, ipcache) `thenRn_`
+ returnRn names
+
+
bindLocatedLocalsRn :: SDoc -- Documentation string for error message
-> [(RdrName,SrcLoc)]
-> ([Name] -> RnMS a)
-> RnMS a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
- = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
-
- getModeRn `thenRn` \ mode ->
+ = getModeRn `thenRn` \ mode ->
getLocalNameEnv `thenRn` \ name_env ->
- -- Warn about shadowing, but only in source modules
+ -- Check for duplicate names
+ checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
+
+ -- Warn about shadowing, but only in source modules
(case mode of
SourceMode | opt_WarnNameShadowing -> mapRn_ (check_shadow name_env) rdr_names_w_loc
other -> returnRn ()
) `thenRn_`
- getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
- n = length rdr_names_w_loc
- (us', us1) = splitUniqSupply us
- uniqs = uniqsFromSupply n us1
- names = [ mk_name uniq (rdrNameOcc rdr_name) loc
- | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
- ]
mk_name = case mode of
SourceMode -> mkLocalName
InterfaceMode -> mkImportedLocalName
-- Keep track of whether the name originally came from
-- an interface file.
in
- setNameSupplyRn (us', cache, ipcache) `thenRn_`
-
+ newLocalsRn mk_name rdr_names_w_loc `thenRn` \ names ->
let
- new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
+ new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
in
- setLocalNameEnv new_name_env (enclosed_scope names)
+ setLocalNameEnv new_local_env (enclosed_scope names)
where
check_shadow name_env (rdr_name,loc)
bindUVarRn = bindLocalRn
-------------------------------------
-extendTyVarEnvFVRn :: [HsTyVarBndr Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
+extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
-- This tiresome function is used only in rnDecl on InstDecl
extendTyVarEnvFVRn tyvars enclosed_scope
- = bindLocalNames tyvar_names enclosed_scope `thenRn` \ (thing, fvs) ->
- returnRn (thing, delListFromNameSet fvs tyvar_names)
- where
- tyvar_names = hsTyVarNames tyvars
+ = bindLocalNames tyvars enclosed_scope `thenRn` \ (thing, fvs) ->
+ returnRn (thing, delListFromNameSet fvs tyvars)
bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
-> ([HsTyVarBndr Name] -> RnMS a)
enclosed_scope names tyvars `thenRn` \ (thing, fvs) ->
returnRn (thing, delListFromNameSet fvs names)
+bindNakedTyVarsFVRn :: SDoc -> [RdrName]
+ -> ([Name] -> RnMS (a, FreeVars))
+ -> RnMS (a, FreeVars)
+bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope
+ = getSrcLocRn `thenRn` \ loc ->
+ let
+ located_tyvars = [(tv, loc) | tv <- tyvar_names]
+ in
+ bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
+ enclosed_scope names `thenRn` \ (thing, fvs) ->
+ returnRn (thing, delListFromNameSet fvs names)
+
-------------------------------------
checkDupOrQualNames, checkDupNames :: SDoc
import UniqFM ( isNullUFM )
import FiniteMap ( elemFM )
import UniqSet ( emptyUniqSet )
-import Util ( removeDups )
-import ListSetOps ( unionLists )
+import ListSetOps ( unionLists, removeDups )
import Maybes ( maybeToBool )
import Outputable
\end{code}
= lookupOccRn con `thenRn` \ con' ->
rnRpats rpats `thenRn` \ (rpats', fvs) ->
returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
+rnPat (TypePatIn name) =
+ (rnHsType (text "type pattern") name) `thenRn` \ (name', fvs) ->
+ returnRn (TypePatIn name', fvs)
\end{code}
************************************************************************
doc_sig = text "a pattern type-signature"
doc_pats = text "in a pattern match"
in
- bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
+ bindNakedTyVarsFVRn doc_sig forall_tyvars $ \ sig_tyvars ->
-- Note that we do a single bindLocalsRn for all the
-- matches together, so that we spot the repeated variable in
rnExpr b2 `thenRn` \ (b2', fvB2) ->
returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
+rnExpr (HsType a) =
+ (rnHsType doc a) `thenRn` \ (t, fvT) -> returnRn (HsType t, fvT)
+ where doc = text "renaming a type pattern"
+
+
rnExpr (ArithSeqIn seq)
= lookupOrigName enumClass_RDR `thenRn` \ enum ->
rn_seq seq `thenRn` \ (new_seq, fvs) ->
import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas )
import TysWiredIn ( tupleTyCon, listTyCon, charTyCon )
-import Name ( Name, getName )
+import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
import Outputable
tupleTyCon_name :: Boxity -> Int -> Name
tupleTyCon_name boxity n = getName (tupleTyCon boxity n)
+extractHsTyVars :: RenamedHsType -> NameSet
+extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x)
+
extractHsTyNames :: RenamedHsType -> NameSet
extractHsTyNames ty
= get ty
where
get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2
- get (HsListTy ty) = unitNameSet listTyCon_name
- `unionNameSets` get ty
+ get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty
get (HsTupleTy (HsTupCon n _) tys) = unitNameSet n
`unionNameSets` extractHsTyNames_s tys
get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2
get (HsPredTy p) = extractHsPredTyNames p
get (HsUsgForAllTy uv ty) = get ty
get (HsUsgTy u ty) = get ty
+ get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets`
+ unitNameSet tycon
+ get (HsNumTy n) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsForAllTy (Just tvs)
ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty)
`minusNameSet`
- mkNameSet (hsTyVarNames tvs)
+ mkNameSet (hsTyVarNames tvs)
get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty)
extractHsTyNames_s :: [RenamedHsType] -> NameSet
extractHsCtxtTyNames :: RenamedContext -> NameSet
extractHsCtxtTyNames ctxt = foldr (unionNameSets . extractHsPredTyNames) emptyNameSet ctxt
--- You don't import or export implicit parameters, so don't mention
--- the IP names
+-- You don't import or export implicit parameters,
+-- so don't mention the IP names
extractHsPredTyNames (HsPClass cls tys)
= unitNameSet cls `unionNameSets` extractHsTyNames_s tys
extractHsPredTyNames (HsPIParam n ty)
= extractHsTyNames ty
\end{code}
+
+%************************************************************************
+%* *
+\subsection{A few functions on generic defintions
+%* *
+%************************************************************************
+
+These functions on generics are defined over RenamedMatches, which is
+why they are here and not in HsMatches.
+
+\begin{code}
+maybeGenericMatch :: RenamedMatch -> Maybe (RenamedHsType, RenamedMatch)
+ -- Tells whether a Match is for a generic definition
+ -- and extract the type from a generic match and put it at the front
+
+maybeGenericMatch (Match tvs (TypePatIn ty : pats) sig_ty grhss)
+ = Just (ty, Match tvs pats sig_ty grhss)
+
+maybeGenericMatch other_match = Nothing
+\end{code}
loadHomeInterface doc_str needed_name `thenRn` \ ifaces ->
case lookupNameEnv (iDecls ifaces) needed_name of
- Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _)))
+ Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _ _)))
-- This case deals with deferred import of algebraic data types
| not opt_NoPruneTyDecls
-> RdrNameHsDecl
-> RnM d (Maybe AvailInfo)
-getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc))
+getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc _ _))
= new_name tycon src_loc `thenRn` \ tycon_name ->
getConFieldNames new_name condecls `thenRn` \ sub_names ->
returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names)))
= new_name tycon src_loc `thenRn` \ tycon_name ->
returnRn (Just (AvailTC tycon_name [tycon_name]))
-getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ _ _ _ src_loc))
+getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ src_loc))
= new_name cname src_loc `thenRn` \ class_name ->
-- Record the names for the class ops
bindings of their own elsewhere.
\begin{code}
-getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname dwname snames src_loc))
- = sequenceRn [new_name n src_loc | n <- (tname : dname : dwname : snames)]
+getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ names
+ src_loc))
+ = sequenceRn [new_name n src_loc | n <- names]
-getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _))
+getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _ _))
= sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
getDeclSysBinders new_name other_decl
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, ErrMsg, WarnMsg, Message
)
-import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc,
+import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
RdrNameEnv, emptyRdrEnv, extendRdrEnv,
lookupRdrEnv, addListToRdrEnv, rdrEnvToList, rdrEnvElts
)
import Name ( Name, OccName, NamedThing(..), getSrcLoc,
isLocallyDefinedName, nameModule, nameOccName,
- decode, mkLocalName, mkUnboundName,
+ decode, mkLocalName, mkUnboundName, mkKnownKeyGlobal,
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList
)
import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom,
)
import NameSet
import CmdLineOpts ( opt_D_dump_rn_trace, opt_HiMap )
-import PrelInfo ( builtinNames )
+import PrelInfo ( wiredInNames, knownKeyRdrNames )
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
-import FiniteMap ( FiniteMap, emptyFM, bagToFM )
+import FiniteMap ( FiniteMap, emptyFM, listToFM, plusFM )
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import UniqSupply
import Outputable
}
builtins :: FiniteMap (ModuleName,OccName) Name
-builtins =
- bagToFM (
- mapBag (\ name -> ((moduleName (nameModule name), nameOccName name), name))
- builtinNames)
+builtins = listToFM wired_in `plusFM` listToFM known_key
+ where
+ wired_in = [ ((moduleName (nameModule name), nameOccName name), name)
+ | name <- wiredInNames ]
+
+ known_key = [ ((rdrNameModule rdr_name, rdrNameOcc rdr_name), mkKnownKeyGlobal rdr_name uniq)
+ | (rdr_name, uniq) <- knownKeyRdrNames ]
\end{code}
@renameSourceCode@ is used to rename stuff ``out-of-line'';
import Outputable
import Maybes ( maybeToBool, catMaybes, mapMaybe )
import UniqFM ( emptyUFM, listToUFM )
-import Util ( removeDups, sortLt )
+import ListSetOps ( removeDups )
+import Util ( sortLt )
import List ( partition )
\end{code}
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
extractRuleBndrsTyVars, extractHsTyRdrTyVars,
- extractHsCtxtRdrTyVars
+ extractHsCtxtRdrTyVars, extractGenericPatTyVars
)
import RnHsSyn
import HsCore
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName,
- lookupOrigNames, lookupSysBinder,
+ lookupOrigNames, lookupSysBinder, newLocalsRn,
bindLocalsFVRn, bindUVarRn,
bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames,
import RnMonad
import FunDeps ( oclose )
-import Class ( FunDep )
+import Class ( FunDep, DefMeth (..) )
import Name ( Name, OccName, nameOccName, NamedThing(..) )
import NameSet
+import OccName ( mkDefaultMethodOcc, isTvOcc )
import FiniteMap ( elemFM )
import PrelInfo ( derivableClassKeys, cCallishClassKeys )
import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
import Unique ( Uniquable(..) )
import ErrUtils ( Message )
import CStrings ( isCLabelString )
-import Util
+import ListSetOps ( minusList, removeDupsEq )
\end{code}
@rnDecl@ `renames' declarations.
However, we can also do some scoping checks at the same time.
\begin{code}
-rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc))
+rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc gen_name1 gen_name2))
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
rnContext data_doc context `thenRn` \ (context', cxt_fvs) ->
checkDupOrQualNames data_doc con_names `thenRn_`
mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) ->
+ lookupSysBinder gen_name1 `thenRn` \ name1' ->
+ lookupSysBinder gen_name2 `thenRn` \ name2' ->
rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
ASSERT(isNoDataPragmas pragmas)
returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
- derivings' noDataPragmas src_loc),
+ derivings' noDataPragmas src_loc name1' name2'),
cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
where
data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
unquantify ty = ty
rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
- tname dname dwname snames src_loc))
+ names src_loc))
= pushSrcLocRn src_loc $
lookupTopBndrRn cname `thenRn` \ cname' ->
-- So the 'Imported' part of this call is not relevant.
-- Unclean; but since these two are the only place this happens
-- I can't work up the energy to do it more beautifully
- lookupSysBinder tname `thenRn` \ tname' ->
- lookupSysBinder dname `thenRn` \ dname' ->
- lookupSysBinder dwname `thenRn` \ dwname' ->
- mapRn lookupSysBinder snames `thenRn` \ snames' ->
+
+ mapRn lookupSysBinder names `thenRn` \ names' ->
-- Tyvars scope over bindings and context
bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
rnContext cls_doc context `thenRn` \ (context', cxt_fvs) ->
-- Check the functional dependencies
- rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) ->
+ rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) ->
-- Check the signatures
+ -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
let
- -- First process the class op sigs, then the fixity sigs.
- (op_sigs, non_op_sigs) = partition isClassOpSig sigs
+ (op_sigs, non_op_sigs) = partition isClassOpSig sigs
+ sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
in
checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) ->
let
- binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
+ binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
in
renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) ->
-- Check the methods
+ -- The newLocals call is tiresome: given a generic class decl
+ -- class C a where
+ -- op :: a -> a
+ -- op {| x+y |} (Inl a) = ...
+ -- op {| x+y |} (Inr b) = ...
+ -- op {| a*b |} (a*b) = ...
+ -- we want to name both "x" tyvars with the same unique, so that they are
+ -- easy to group together in the typechecker.
+ -- Hence the
+ getLocalNameEnv `thenRn` \ name_env ->
+ let
+ meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
+ gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
+ not (tv `elemFM` name_env)]
+ in
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
- rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) ->
+ newLocalsRn mkLocalName gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
+ rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
-- Typechecker is responsible for checking that we only
-- give default-method bindings for things in this class.
ASSERT(isNoClassPragmas pragmas)
returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
- NoClassPragmas tname' dname' dwname' snames' src_loc),
+ NoClassPragmas names' src_loc),
sig_fvs `plusFV`
+
fix_fvs `plusFV`
cxt_fvs `plusFV`
fds_fvs `plusFV`
sig_doc = text "the signatures for class" <+> ppr cname
meth_doc = text "the default-methods for class" <+> ppr cname
- sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
- meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
-
rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
= pushSrcLocRn locn $
lookupTopBndrRn op `thenRn` \ op_name ->
(case maybe_dm_stuff of
Nothing -> returnRn (Nothing, emptyFVs) -- Source-file class decl
- Just (dm_rdr_name, explicit_dm)
+ Just (DefMeth dm_rdr_name)
-> -- Imported class that has a default method decl
-- See comments with tname, snames, above
lookupSysBinder dm_rdr_name `thenRn` \ dm_name ->
- returnRn (Just (dm_name, explicit_dm),
- if explicit_dm then unitFV dm_name else emptyFVs)
+ returnRn (Just (DefMeth dm_name), unitFV dm_name)
-- An imported class decl for a class decl that had an explicit default
-- method, mentions, rather than defines,
-- the default method, so we must arrange to pull it in
+ Just GenDefMeth
+ -> returnRn (Just GenDefMeth, emptyFVs)
+ Just NoDefMeth
+ -> returnRn (Just NoDefMeth, emptyFVs)
) `thenRn` \ (maybe_dm_stuff', dm_fvs) ->
returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn, op_ty_fvs `plusFV` dm_fvs)
-- Rename the bindings
-- NB meth_names can be qualified!
checkDupNames meth_doc meth_names `thenRn_`
- extendTyVarEnvFVRn inst_tyvars (
- rnMethodBinds mbinds
+ extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
+ rnMethodBinds [] mbinds
) `thenRn` \ (mbinds', meth_fvs) ->
let
- binders = map fst (bagToList (collectMonoBinders mbinds'))
+ binders = collectMonoBinders mbinds'
binder_set = mkNameSet binders
in
-- Rename the prags and signatures.
returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc),
inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
where
- meth_doc = text "the bindings in an instance declaration"
- meth_names = bagToList (collectMonoBinders mbinds)
+ meth_doc = text "the bindings in an instance declaration"
+ meth_names = collectLocatedMonoBinders mbinds
\end{code}
%*********************************************************
= lookupOccRn tyvar `thenRn` \ tyvar' ->
returnRn (HsTyVar tyvar', unitFV tyvar')
+rnHsType doc (HsOpTy ty1 opname ty2)
+ = lookupOccRn opname `thenRn` \ name' ->
+ rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
+ rnHsType doc ty2 `thenRn` \ (ty2',fvs2) ->
+ returnRn (HsOpTy ty1' name' ty2', fvs1 `plusFV` fvs2 `addOneFV` name')
+
+rnHsType doc (HsNumTy i)
+ | i == 1 = returnRn (HsNumTy i, emptyFVs)
+ | otherwise = failWithRn (HsNumTy i, emptyFVs)
+ (ptext SLIT("Only unit numeric type pattern is valid"))
+
rnHsType doc (HsFunTy ty1 ty2)
= rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
-- Might find a for-all as the arg of a function type
newTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
let
forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
- binder_names = map fst (bagToList (collectMonoBinders mbind))
+ binder_names = collectMonoBinders mbind
poly_ids = map mk_dummy binder_names
mk_dummy name = case maybeSig tc_ty_sigs name of
Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
-- at all.
pat_binders :: [Name]
- pat_binders = map fst $ bagToList $ collectMonoBinders $
- (justPatBindings mbind EmptyMonoBinds)
+ pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)
in
-- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS
mapTc (\id -> checkTc (not (idName id `elem` pat_binders
\begin{code}
module TcClassDcl ( tcClassDecl1, tcClassDecls2, mkImplicitClassBinds,
- tcMethodBind, checkFromThisClass
+ tcMethodBind, badMethodErr
) where
#include "HsVersions.h"
import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
HsExpr(..), HsLit(..), HsType(..), HsPred(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
- isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
+ isClassDecl, isClassOpSig, isPragSig,
+ fromClassDeclNameList, tyClDeclName
)
-import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
+import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..), EP(..) )
import RnHsSyn ( RenamedTyClDecl,
RenamedClassOpSig, RenamedMonoBinds,
- RenamedContext, RenamedHsDecl, RenamedSig
+ RenamedContext, RenamedHsDecl, RenamedSig,
+ RenamedHsExpr, maybeGenericMatch
)
import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars )
import TcMonad
+import Generics ( mkGenericRhs, validGenericMethodType )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
+import Class ( classTyVars, classBigSig, classSelIds, classTyCon, Class, ClassOpItem,
+ DefMeth (..) )
import Bag ( bagToList )
-import Class ( classTyVars, classBigSig, classSelIds, classTyCon, Class, ClassOpItem )
-import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
+import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods, opt_PprStyle_Debug )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
import Id ( Id, idType, idName )
-import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
+import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..), mkSysLocalName,
+ NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
import NameSet ( NameSet, mkNameSet, elemNameSet, emptyNameSet )
import Outputable
-import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkSigmaTy, mkClassPred )
+import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkSigmaTy, mkClassPred,
+ splitTyConApp_maybe, isTyVarTy
+ )
import Var ( TyVar )
import VarSet ( mkVarSet, emptyVarSet )
-import Maybes ( seqMaybe )
+import ErrUtils ( dumpIfSet )
+import Util ( count )
+import Maybes ( seqMaybe, maybeToBool, orElse )
\end{code}
tcClassDecl1 rec_env
(ClassDecl context class_name
tyvar_names fundeps class_sigs def_methods pragmas
- tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
+ sys_names src_loc)
= -- CHECK ARITY 1 FOR HASKELL 1.4
checkTc (opt_GlasgowExts || length tyvar_names == 1)
(classArityErr class_name) `thenTc_`
-- LOOK THINGS UP IN THE ENVIRONMENT
tcLookupTy class_name `thenTc` \ (AClass clas) ->
let
- tyvars = classTyVars clas
- dm_bndrs_w_locs = bagToList (collectMonoBinders def_methods)
- dm_bndr_set = mkNameSet (map fst dm_bndrs_w_locs)
+ tyvars = classTyVars clas
+ op_sigs = filter isClassOpSig class_sigs
+ op_names = [n | ClassOpSig n _ _ _ <- op_sigs]
+ (_, datacon_name, datacon_wkr_name, sc_sel_names) = fromClassDeclNameList sys_names
in
- tcExtendTyVarEnv tyvars $
+ tcExtendTyVarEnv tyvars $
+
+ -- CHECK THAT THE DEFAULT BINDINGS ARE LEGAL
+ checkDefaultBinds clas op_names def_methods `thenTc` \ dm_info ->
+ checkGenericClassIsUnary clas dm_info `thenTc_`
-- CHECK THE CONTEXT
- tcSuperClasses class_name clas
- context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) ->
+ tcSuperClasses clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) ->
-- CHECK THE CLASS SIGNATURES,
- mapTc (tcClassSig rec_env dm_bndr_set clas tyvars)
- (filter isClassOpSig class_sigs) `thenTc` \ sig_stuff ->
+ mapTc (tcClassSig rec_env clas tyvars dm_info) op_sigs `thenTc` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
let
dict_component_tys = sc_tys ++ op_tys
dict_con = mkDataCon datacon_name
- [notMarkedStrict | _ <- dict_component_tys]
- [{- No labelled fields -}]
- tyvars
- [{-No context-}]
- [{-No existential tyvars-}] [{-Or context-}]
- dict_component_tys
- (classTyCon clas)
- dict_con_id dict_wrap_id
+ [notMarkedStrict | _ <- dict_component_tys]
+ [{- No labelled fields -}]
+ tyvars
+ [{-No context-}]
+ [{-No existential tyvars-}] [{-Or context-}]
+ dict_component_tys
+ (classTyCon clas)
+ dict_con_id dict_wrap_id
dict_con_id = mkDataConId datacon_wkr_name dict_con
dict_wrap_id = mkDataConWrapId dict_con
\end{code}
\begin{code}
-tcSuperClasses :: Name -> Class
+checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds -> TcM s (NameEnv (DefMeth Name))
+ -- Check default bindings
+ -- a) must be for a class op for this class
+ -- b) must be all generic or all non-generic
+ -- and return a mapping from class-op to DefMeth info
+
+checkDefaultBinds clas ops EmptyMonoBinds = returnTc emptyNameEnv
+
+checkDefaultBinds clas ops (AndMonoBinds b1 b2)
+ = checkDefaultBinds clas ops b1 `thenTc` \ dm_info1 ->
+ checkDefaultBinds clas ops b2 `thenTc` \ dm_info2 ->
+ returnTc (dm_info1 `plusNameEnv` dm_info2)
+
+checkDefaultBinds clas ops (FunMonoBind op _ matches loc)
+ = tcAddSrcLoc loc $
+
+ -- Check that the op is from this class
+ checkTc (op `elem` ops) (badMethodErr clas op) `thenTc_`
+
+ -- Check that all the defns ar generic, or none are
+ checkTc (all_generic || none_generic) (mixedGenericErr op) `thenTc_`
+
+ -- Make up the right dm_info
+ if all_generic then
+ returnTc (unitNameEnv op GenDefMeth)
+ else
+ -- An explicit non-generic default method
+ newDefaultMethodName op loc `thenNF_Tc` \ dm_name ->
+ returnTc (unitNameEnv op (DefMeth dm_name))
+
+ where
+ n_generic = count (maybeToBool . maybeGenericMatch) matches
+ none_generic = n_generic == 0
+ all_generic = n_generic == length matches
+
+checkGenericClassIsUnary clas dm_info
+ = -- Check that if the class has generic methods, then the
+ -- class has only one parameter. We can't do generic
+ -- multi-parameter type classes!
+ checkTc (unary || no_generics) (genericMultiParamErr clas)
+ where
+ unary = length (classTyVars clas) == 1
+ no_generics = null [() | GenDefMeth <- nameEnvElts dm_info]
+\end{code}
+
+
+\begin{code}
+tcSuperClasses :: Class
-> RenamedContext -- class context
-> [Name] -- Names for superclass selectors
-> TcM s (ClassContext, -- the superclass context
[Id]) -- superclass selector Ids
-tcSuperClasses class_name clas context sc_sel_names
+tcSuperClasses clas context sc_sel_names
= -- Check the context.
-- The renamer has already checked that the context mentions
-- only the type variable of the class decl.
where
check_constraint sc@(HsPClass c tys)
- = checkTc (all is_tyvar tys) (superClassErr class_name sc)
+ = checkTc (all is_tyvar tys) (superClassErr clas sc)
is_tyvar (HsTyVar _) = True
is_tyvar other = False
-tcClassSig :: ValueEnv -- Knot tying only!
- -> NameSet -- Names bound in the default-method bindings
+tcClassSig :: ValueEnv -- Knot tying only!
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
+ -> NameEnv (DefMeth Name) -- Info about default methods
-> RenamedClassOpSig
-> TcM s (Type, -- Type of the method
ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding
+-- This warrants an explanation: we need to separate generic
+-- default methods and default methods later on in the compiler
+-- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
+-- Class.DefMeth data structure.
-tcClassSig rec_env dm_bind_names clas clas_tyvars
- (ClassOpSig op_name maybe_dm_stuff op_ty src_loc)
+tcClassSig rec_env clas clas_tyvars dm_info
+ (ClassOpSig op_name maybe_dm op_ty src_loc)
= tcAddSrcLoc src_loc $
-- Check the type signature. NB that the envt *already has*
-- Build the selector id and default method id
sel_id = mkDictSelId op_name clas
+
+ dm_info_name = maybe_dm `orElse` lookupNameEnv dm_info op_name `orElse` NoDefMeth
+
+ dm_info_id = case dm_info_name of
+ NoDefMeth -> NoDefMeth
+ GenDefMeth -> GenDefMeth
+ DefMeth dm_name -> DefMeth (tcAddImportedIdInfo rec_env dm_id)
+ where
+ dm_id = mkDefaultMethodId dm_name clas global_ty
in
- (case maybe_dm_stuff of
- Nothing -> -- Source-file class declaration
- newDefaultMethodName op_name src_loc `thenNF_Tc` \ dm_name ->
- returnNF_Tc (mkDefaultMethodId dm_name clas global_ty, op_name `elemNameSet` dm_bind_names)
-
- Just (dm_name, explicit_dm) -> -- Interface-file class decl
- let
- dm_id = mkDefaultMethodId dm_name clas global_ty
- in
- returnNF_Tc (tcAddImportedIdInfo rec_env dm_id, explicit_dm)
- ) `thenNF_Tc` \ (dm_id, explicit_dm) ->
-
- returnTc (local_ty, (sel_id, dm_id, explicit_dm))
+ -- Check that for a generic method, the type of
+ -- the method is sufficiently simple
+ checkTc (dm_info_name /= GenDefMeth || validGenericMethodType local_ty)
+ (badGenericMethodType op_name op_ty) `thenTc_`
+
+ returnTc (local_ty, (sel_id, dm_info_id))
\end{code}
%* *
%************************************************************************
-The purpose of pass 2 is
-\begin{enumerate}
-\item
-to beat on the explicitly-provided default-method decls (if any),
-using them to produce a complete set of default-method decls.
-(Omitted ones elicit an error message.)
-\item
-to produce a definition for the selector function for each method
+@mkImplicitClassBinds@ produces a binding for the selector function for each method
and superclass dictionary.
-\end{enumerate}
-
-Pass~2 only applies to locally-defined class declarations.
-
-The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
-each local class decl.
-
-\begin{code}
-tcClassDecls2 :: [RenamedHsDecl]
- -> NF_TcM s (LIE, TcMonoBinds)
-
-tcClassDecls2 decls
- = foldr combine
- (returnNF_Tc (emptyLIE, EmptyMonoBinds))
- [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl]
- where
- combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
- tc2 `thenNF_Tc` \ (lie2, binds2) ->
- returnNF_Tc (lie1 `plusLIE` lie2,
- binds1 `AndMonoBinds` binds2)
-\end{code}
-
-@tcClassDecl2@ is the business end of things.
-
-\begin{code}
-tcClassDecl2 :: RenamedTyClDecl -- The class declaration
- -> NF_TcM s (LIE, TcMonoBinds)
-
-tcClassDecl2 (ClassDecl context class_name
- tyvar_names _ class_sigs default_binds pragmas _ _ _ _ src_loc)
-
- | not (isLocallyDefined class_name)
- = returnNF_Tc (emptyLIE, EmptyMonoBinds)
-
- | otherwise -- It is locally defined
- = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
- tcAddSrcLoc src_loc $
- tcLookupTy class_name `thenNF_Tc` \ (AClass clas) ->
- tcDefaultMethodBinds clas default_binds class_sigs
-\end{code}
\begin{code}
mkImplicitClassBinds :: [Class] -> NF_TcM s ([Id], TcMonoBinds)
| otherwise = EmptyMonoBinds
\end{code}
+
+
%************************************************************************
%* *
\subsection[Default methods]{Default methods}
dfoo_list
\end{verbatim}
+The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
+each local class decl.
+
\begin{code}
-tcDefaultMethodBinds
- :: Class
- -> RenamedMonoBinds
- -> [RenamedSig]
- -> TcM s (LIE, TcMonoBinds)
-
-tcDefaultMethodBinds clas default_binds sigs
- = -- Check that the default bindings come from this class
- checkFromThisClass clas default_binds `thenNF_Tc_`
-
- -- Do each default method separately
- -- For Hugs compatibility we make a default-method for every
- -- class op, regardless of whether or not the programmer supplied an
- -- explicit default decl for the class. GHC will actually never
- -- call the default method for such operations, because it'll whip up
- -- a more-informative default method at each instance decl.
- mapAndUnzipTc tc_dm op_items `thenTc` \ (defm_binds, const_lies) ->
+tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM s (LIE, TcMonoBinds)
- returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
+tcClassDecls2 decls
+ = foldr combine
+ (returnNF_Tc (emptyLIE, EmptyMonoBinds))
+ [tcClassDecl2 cls_decl | TyClD cls_decl <- decls,
+ isClassDecl cls_decl,
+ isLocallyDefined (tyClDeclName cls_decl)]
where
- prags = filter isPragSig sigs
+ combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
+ tc2 `thenNF_Tc` \ (lie2, binds2) ->
+ returnNF_Tc (lie1 `plusLIE` lie2,
+ binds1 `AndMonoBinds` binds2)
+\end{code}
- (tyvars, _, _, op_items) = classBigSig clas
+@tcClassDecl2@ generates bindings for polymorphic default methods
+(generic default methods have by now turned into instance declarations)
- origin = ClassDeclOrigin
+\begin{code}
+tcClassDecl2 :: RenamedTyClDecl -- The class declaration
+ -> NF_TcM s (LIE, TcMonoBinds)
+
+tcClassDecl2 (ClassDecl context class_name
+ tyvar_names _ sigs default_binds pragmas _ src_loc)
+ = -- A locally defined class
+ recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
+ tcAddSrcLoc src_loc $
+ tcLookupTy class_name `thenNF_Tc` \ (AClass clas) ->
+
+ -- We make a separate binding for each default method.
+ -- At one time I used a single AbsBinds for all of them, thus
+ -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
+ -- But that desugars into
+ -- ds = \d -> (..., ..., ...)
+ -- dm1 = \d -> case ds d of (a,b,c) -> a
+ -- And since ds is big, it doesn't get inlined, so we don't get good
+ -- default methods. Better to make separate AbsBinds for each
+ let
+ (tyvars, _, _, op_items) = classBigSig clas
+ prags = filter isPragSig sigs
+ tc_dm = tcDefMeth clas tyvars default_binds prags
+ in
+ mapAndUnzipTc tc_dm op_items `thenTc` \ (defm_binds, const_lies) ->
- -- We make a separate binding for each default method.
- -- At one time I used a single AbsBinds for all of them, thus
- -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
- -- But that desugars into
- -- ds = \d -> (..., ..., ...)
- -- dm1 = \d -> case ds d of (a,b,c) -> a
- -- And since ds is big, it doesn't get inlined, so we don't get good
- -- default methods. Better to make separate AbsBinds for each
+ returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
- tc_dm op_item@(_, dm_id, _)
- = tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
- let
- theta = [(mkClassPred clas inst_tys)]
- in
- newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
- let
- avail_insts = this_dict
- in
- tcExtendTyVarEnvForMeths tyvars clas_tyvars (
- tcMethodBind clas origin clas_tyvars inst_tys theta
- default_binds prags False
- op_item
- ) `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->
+
+tcDefMeth clas tyvars binds_in prags (_, NoDefMeth) = returnTc (EmptyMonoBinds, emptyLIE)
+tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds, emptyLIE)
+ -- Generate code for polymorphic default methods only
+ -- (Generic default methods have turned into instance decls by now.)
+ -- This is incompatible with Hugs, which expects a polymorphic
+ -- default method for every class op, regardless of whether or not
+ -- the programmer supplied an explicit default decl for the class.
+ -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
+
+tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id)
+ = tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
+ let
+ theta = [(mkClassPred clas inst_tys)]
+ in
+ newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+
+ tcExtendTyVarEnvForMeths tyvars clas_tyvars (
+ tcMethodBind clas origin clas_tyvars inst_tys theta
+ binds_in prags False op_item
+ ) `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->
- tcAddErrCtxt (defltMethCtxt clas) $
+ tcAddErrCtxt (defltMethCtxt clas) $
- -- tcMethodBind has checked that the class_tyvars havn't
- -- been unified with each other or another type, but we must
- -- still zonk them before passing them to tcSimplifyAndCheck
- zonkTcSigTyVars clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
+ -- tcMethodBind has checked that the class_tyvars havn't
+ -- been unified with each other or another type, but we must
+ -- still zonk them before passing them to tcSimplifyAndCheck
+ zonkTcSigTyVars clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
- -- Check the context
- tcSimplifyAndCheck
- (ptext SLIT("class") <+> ppr clas)
- (mkVarSet clas_tyvars')
- avail_insts
- insts_needed `thenTc` \ (const_lie, dict_binds) ->
+ -- Check the context
+ tcSimplifyAndCheck
+ (ptext SLIT("class") <+> ppr clas)
+ (mkVarSet clas_tyvars')
+ this_dict
+ insts_needed `thenTc` \ (const_lie, dict_binds) ->
- let
- full_bind = AbsBinds
- clas_tyvars'
- [this_dict_id]
- [(clas_tyvars', dm_id, local_dm_id)]
- emptyNameSet -- No inlines (yet)
- (dict_binds `andMonoBinds` defm_bind)
- in
- returnTc (full_bind, const_lie)
-\end{code}
-
-\begin{code}
-checkFromThisClass :: Class -> RenamedMonoBinds -> NF_TcM s ()
-checkFromThisClass clas mbinds
- = mapNF_Tc check_from_this_class bndrs_w_locs `thenNF_Tc_`
- returnNF_Tc ()
+ let
+ full_bind = AbsBinds
+ clas_tyvars'
+ [this_dict_id]
+ [(clas_tyvars', dm_id, local_dm_id)]
+ emptyNameSet -- No inlines (yet)
+ (dict_binds `andMonoBinds` defm_bind)
+ in
+ returnTc (full_bind, const_lie)
where
- check_from_this_class (bndr, loc)
- | nameOccName bndr `elem` sel_names = returnNF_Tc ()
- | otherwise = tcAddSrcLoc loc $
- addErrTc (badMethodErr bndr clas)
- sel_names = map getOccName (classSelIds clas)
- bndrs_w_locs = bagToList (collectMonoBinders mbinds)
+ origin = ClassDeclOrigin
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Typechecking a method}
+%* *
+%************************************************************************
+
@tcMethodBind@ is used to type-check both default-method and
instance-decl method declarations. We must type-check methods one at a
time, because their signatures may have different contexts and
-> TcM s (TcMonoBinds, LIE, (LIE, TcId))
tcMethodBind clas origin inst_tyvars inst_tys inst_theta
- meth_binds prags is_inst_decl
- (sel_id, dm_id, explicit_dm)
- = tcGetSrcLoc `thenNF_Tc` \ loc ->
-
- newMethod origin sel_id inst_tys `thenNF_Tc` \ meth@(_, meth_id) ->
- mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
-
- let
- meth_name = idName meth_id
- maybe_user_bind = find_bind meth_name meth_binds
-
- no_user_bind = case maybe_user_bind of {Nothing -> True; other -> False}
-
- meth_bind = case maybe_user_bind of
- Just bind -> bind
- Nothing -> mk_default_bind meth_name loc
-
- meth_prags = find_prags meth_name prags
- in
-
- -- Warn if no method binding, only if -fwarn-missing-methods
- warnTc (is_inst_decl && opt_WarnMissingMethods && no_user_bind && not explicit_dm)
- (omittedMethodWarn sel_id clas) `thenNF_Tc_`
-
- -- Check the bindings; first add inst_tyvars to the envt
- -- so that we don't quantify over them in nested places
- -- The *caller* put the class/inst decl tyvars into the envt
- tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
- tcAddErrCtxt (methodCtxt sel_id) $
- tcBindWithSigs NotTopLevel meth_bind
- [sig_info] meth_prags NonRecursive
- ) `thenTc` \ (binds, insts, _) ->
-
-
- tcExtendLocalValEnv [(meth_name, meth_id)] (
- tcSpecSigs meth_prags
- ) `thenTc` \ (prag_binds1, prag_lie) ->
-
- -- The prag_lie for a SPECIALISE pragma will mention the function
- -- itself, so we have to simplify them away right now lest they float
- -- outwards!
- bindInstsOfLocalFuns prag_lie [meth_id] `thenTc` \ (prag_lie', prag_binds2) ->
-
-
- -- Now check that the instance type variables
- -- (or, in the case of a class decl, the class tyvars)
- -- have not been unified with anything in the environment
- --
- -- We do this for each method independently to localise error messages
- tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id)) $
- checkSigTyVars inst_tyvars emptyVarSet `thenTc_`
-
- returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
- insts `plusLIE` prag_lie',
- meth)
- where
- sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_name
-
- sel_name = idName sel_id
-
- -- The renamer just puts the selector ID as the binder in the method binding
- -- but we must use the method name; so we substitute it here. Crude but simple.
- find_bind meth_name (FunMonoBind op_name fix matches loc)
- | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
- find_bind meth_name (AndMonoBinds b1 b2)
- = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
- find_bind meth_name other = Nothing -- Default case
-
-
- -- Find the prags for this method, and replace the
- -- selector name with the method name
- find_prags meth_name [] = []
- find_prags meth_name (SpecSig name ty loc : prags)
- | name == sel_name = SpecSig meth_name ty loc : find_prags meth_name prags
- find_prags meth_name (InlineSig name phase loc : prags)
- | name == sel_name = InlineSig meth_name phase loc : find_prags meth_name prags
- find_prags meth_name (NoInlineSig name phase loc : prags)
- | name == sel_name = NoInlineSig meth_name phase loc : find_prags meth_name prags
- find_prags meth_name (prag:prags) = find_prags meth_name prags
-
- mk_default_bind local_meth_name loc
- = FunMonoBind local_meth_name
- False -- Not infix decl
- [mkSimpleMatch [] (default_expr loc) Nothing loc]
- loc
-
- default_expr loc
- | explicit_dm = HsVar (getName dm_id) -- There's a default method
- | otherwise = error_expr loc -- No default method
-
- error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
- (HsLit (HsString (_PK_ (error_msg loc))))
-
- error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+ meth_binds prags is_inst_decl (sel_id, dm_info)
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ newMethod origin sel_id inst_tys `thenNF_Tc` \ meth@(_, meth_id) ->
+ mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
+ let
+ meth_name = idName meth_id
+ sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_id
+ meth_prags = find_prags (idName sel_id) meth_name prags
+ in
+ -- Figure out what method binding to use
+ -- If the user suppplied one, use it, else construct a default one
+ (case find_bind (idName sel_id) meth_name meth_binds of
+ Just user_bind -> returnTc user_bind
+ Nothing -> mkDefMethRhs is_inst_decl clas inst_tys sel_id loc dm_info `thenTc` \ rhs ->
+ returnTc (FunMonoBind meth_name False -- Not infix decl
+ [mkSimpleMatch [] rhs Nothing loc] loc)
+ ) `thenTc` \ meth_bind ->
+ -- Check the bindings; first add inst_tyvars to the envt
+ -- so that we don't quantify over them in nested places
+ -- The *caller* put the class/inst decl tyvars into the envt
+ tcExtendGlobalTyVars (mkVarSet inst_tyvars)
+ (tcAddErrCtxt (methodCtxt sel_id) $
+ tcBindWithSigs NotTopLevel meth_bind
+ [sig_info] meth_prags NonRecursive
+ ) `thenTc` \ (binds, insts, _) ->
+
+ tcExtendLocalValEnv [(meth_name, meth_id)]
+ (tcSpecSigs meth_prags) `thenTc` \ (prag_binds1, prag_lie) ->
+
+ -- The prag_lie for a SPECIALISE pragma will mention the function
+ -- itself, so we have to simplify them away right now lest they float
+ -- outwards!
+ bindInstsOfLocalFuns prag_lie [meth_id] `thenTc` \ (prag_lie', prag_binds2) ->
+
+ -- Now check that the instance type variables
+ -- (or, in the case of a class decl, the class tyvars)
+ -- have not been unified with anything in the environment
+ --
+ -- We do this for each method independently to localise error messages
+ tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id)) $
+ checkSigTyVars inst_tyvars emptyVarSet `thenTc_`
+
+ returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
+ insts `plusLIE` prag_lie',
+ meth)
+
+ -- The user didn't supply a method binding,
+ -- so we have to make up a default binding
+ -- The RHS of a default method depends on the default-method info
+mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_id)
+ = -- An polymorphic default method
+ returnTc (HsVar (idName dm_id))
+
+mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth
+ = -- No default method
+ -- Warn only if -fwarn-missing-methods
+ warnTc (is_inst_decl && opt_WarnMissingMethods)
+ (omittedMethodWarn sel_id clas) `thenNF_Tc_`
+ returnTc error_rhs
+ where
+ error_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
+ (HsLit (HsString (_PK_ error_msg)))
+ error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+
+
+mkDefMethRhs is_inst_decl clas inst_tys sel_id loc GenDefMeth
+ = -- A generic default method
+ -- If the method is defined generically, we can only do the job if the
+ -- instance declaration is for a single-parameter type class with
+ -- a type constructor applied to type arguments in the instance decl
+ -- (checkTc, so False provokes the error)
+ checkTc (not is_inst_decl || simple_inst)
+ (badGenericInstance sel_id clas) `thenTc_`
+
+ ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenNF_Tc_`
+ returnTc rhs
+ where
+ rhs = mkGenericRhs sel_id clas_tyvar tycon
+
+ stuff = vcat [ppr clas <+> ppr inst_tys,
+ nest 4 (ppr sel_id <+> equals <+> ppr rhs)]
+
+ -- The tycon is only used in the generic case, and in that
+ -- case we require that the instance decl is for a single-parameter
+ -- type class with type variable arguments:
+ -- instance (...) => C (T a b)
+ simple_inst = maybeToBool maybe_tycon
+ clas_tyvar = head (classTyVars clas)
+ Just tycon = maybe_tycon
+ maybe_tycon = case inst_tys of
+ [ty] -> case splitTyConApp_maybe ty of
+ Just (tycon, arg_tys) | all isTyVarTy arg_tys -> Just tycon
+ other -> Nothing
+ other -> Nothing
+\end{code}
+
+
+\begin{code}
+-- The renamer just puts the selector ID as the binder in the method binding
+-- but we must use the method name; so we substitute it here. Crude but simple.
+find_bind sel_name meth_name (FunMonoBind op_name fix matches loc)
+ | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
+find_bind sel_name meth_name (AndMonoBinds b1 b2)
+ = find_bind sel_name meth_name b1 `seqMaybe` find_bind sel_name meth_name b2
+find_bind sel_name meth_name other = Nothing -- Default case
+
+ -- Find the prags for this method, and replace the
+ -- selector name with the method name
+find_prags sel_name meth_name [] = []
+find_prags sel_name meth_name (SpecSig name ty loc : prags)
+ | name == sel_name = SpecSig meth_name ty loc : find_prags sel_name meth_name prags
+find_prags sel_name meth_name (InlineSig name phase loc : prags)
+ | name == sel_name = InlineSig meth_name phase loc : find_prags sel_name meth_name prags
+find_prags sel_name meth_name (NoInlineSig name phase loc : prags)
+ | name == sel_name = NoInlineSig meth_name phase loc : find_prags sel_name meth_name prags
+find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
\end{code}
+
Contexts and errors
~~~~~~~~~~~~~~~~~~~
\begin{code}
classArityErr class_name
= ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
-superClassErr class_name sc
+superClassErr clas sc
= ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc)
- <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
+ <+> ptext SLIT("in declaration for class") <+> quotes (ppr clas)
-defltMethCtxt class_name
- = ptext SLIT("When checking the default methods for class") <+> quotes (ppr class_name)
+defltMethCtxt clas
+ = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
methodCtxt sel_id
= ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
-badMethodErr bndr clas
+badMethodErr clas op
= hsep [ptext SLIT("Class"), quotes (ppr clas),
- ptext SLIT("does not have a method"), quotes (ppr bndr)]
+ ptext SLIT("does not have a method"), quotes (ppr op)]
omittedMethodWarn sel_id clas
= sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
+
+badGenericMethodType op op_ty
+ = hang (ptext SLIT("Generic method type is too complex"))
+ 4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
+ ptext SLIT("You can only use type variables, arrows, and tuples")])
+
+badGenericInstance sel_id clas
+ = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
+ ptext SLIT("because the instance declaration is not for a simple type (T a b c)"),
+ ptext SLIT("(where T is a derivable type constructor)"),
+ ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
+
+mixedGenericErr op
+ = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
+
+genericMultiParamErr clas
+ = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+>
+ ptext SLIT("cannot have generic methods")
\end{code}
#include "HsVersions.h"
-import HsSyn ( HsBinds(..), MonoBinds(..), collectMonoBinders )
+import HsSyn ( HsBinds(..), MonoBinds(..), collectLocatedMonoBinders )
import RdrHsSyn ( RdrNameMonoBinds )
import RnHsSyn ( RenamedHsBinds )
import CmdLineOpts ( opt_D_dump_deriv )
import TcMonad
import TcEnv ( InstEnv, getEnvTyCons, tcSetInstEnv, newDFunName )
import TcGenDeriv -- Deriv stuff
-import TcInstUtil ( InstInfo(..), buildInstanceEnv )
+import TcInstUtil ( InstInfo(..), pprInstInfo, instInfoClass, simpleInstInfoTyCon, buildInstanceEnv )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
import Var ( TyVar )
import PrelNames
import Bag ( bagToList )
-import Util ( zipWithEqual, sortLt, removeDups, assoc, thenCmp )
+import Util ( zipWithEqual, sortLt, thenCmp )
+import ListSetOps ( removeDups, assoc )
import Outputable
\end{code}
extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
method_binds_s = map (gen_bind fixs) new_inst_infos
- mbinders = bagToList (collectMonoBinders extra_mbinds)
+ mbinders = collectLocatedMonoBinders extra_mbinds
-- Rename to get RenamedBinds.
-- The only tricky bit is that the extra_binds must scope over the
where
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
ddump_deriving inst_infos extra_binds
- = vcat (map pp_info inst_infos) $$ ppr extra_binds
+ = vcat (map pprInstInfo inst_infos) $$ ppr extra_binds
where
- pp_info (InstInfo clas tvs [ty] inst_decl_theta _ mbinds _ _)
- = ppr (mkSigmaTy tvs inst_decl_theta' (mkDictTy clas [ty]))
- $$
- ppr mbinds
- where inst_decl_theta' = classesToPreds inst_decl_theta
-- Paste the dfun id and method binds into the InstInfo
gen_inst_info (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _, meth_binds)
returnNF_Tc (InstInfo clas tyvars tys inst_decl_theta
dfun_id meth_binds locn [])
- rn_meths meths = rnMethodBinds meths `thenRn` \ (meths', _) -> returnRn meths'
+ rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
-- Ignore the free vars returned
\end{code}
mk_deriv_inst_info (clas, tycon, tyvars, _) theta
= InstInfo clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)]
- theta
+ theta'
dummy_dfun_id
(my_panic "binds") (getSrcLoc tycon)
(my_panic "upragmas")
-- (paired with class name, as we need that when generating dict
-- names.)
gen_bind :: FixityEnv -> InstInfo -> RdrNameMonoBinds
-gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _)
- | not from_here = EmptyMonoBinds
- | clas `hasKey` showClassKey = gen_Show_binds fixities tycon
- | clas `hasKey` readClassKey = gen_Read_binds fixities tycon
+gen_bind fixities inst
+ | not (isLocallyDefined tycon) = EmptyMonoBinds
+ | clas `hasKey` showClassKey = gen_Show_binds fixities tycon
+ | clas `hasKey` readClassKey = gen_Read_binds fixities tycon
| otherwise
= assoc "gen_bind:bad derived class"
[(eqClassKey, gen_Eq_binds)
(classKey clas)
tycon
where
- from_here = isLocallyDefined tycon
- (tycon,_,_) = splitAlgTyConApp ty
+ clas = instInfoClass inst
+ tycon = simpleInstInfoTyCon inst
\end{code}
foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
foldlTc do_tag2con names_so_far tycons_of_interest
where
- all_CTs = [ (c, get_tycon ty) | (InstInfo c _ [ty] _ _ _ _ _) <- inst_infos ]
+ all_CTs = [ (instInfoClass info, simpleInstInfoTyCon info) | info <- inst_infos ]
- get_tycon ty = case splitAlgTyConApp ty of { (tc, _, _) -> tc }
-
- all_tycons = map snd all_CTs
+ all_tycons = map snd all_CTs
(tycons_of_interest, _) = removeDups compare all_tycons
do_con2tag acc_Names tycon
Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
returnNF_Tc (lookupWithDefaultUFM ve def name)
where
- def = pprPanic "tcLookupValue:" (ppr name)
+ wired_in = case maybeWiredInIdName name of
+ Just id -> True
+ Nothing -> False
+ def = pprPanic "tcLookupValue:" (ppr name <+> ppr wired_in)
tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
tcLookupValueMaybe name
\section[TcInstDecls]{Typechecking instance declarations}
\begin{code}
-module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
+module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), InstDecl(..),
+
+import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances, opt_D_dump_deriv )
+
+import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
- andMonoBindList
+ andMonoBindList, collectMonoBinders, isClassDecl
)
-import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
+import HsTypes ( HsType (..), HsTyVarBndr(..), toHsTyVar )
+import HsPat ( InPat (..) )
+import HsMatches ( Match (..) )
+import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, extractHsTyVars )
import TcHsSyn ( TcMonoBinds, mkHsConApp )
-
import TcBinds ( tcSpecSigs )
-import TcClassDcl ( tcMethodBind, checkFromThisClass )
-import TcMonad
+import TcClassDcl ( tcMethodBind, badMethodErr )
+import TcMonad
import RnMonad ( RnNameSupply, FixityEnv )
import Inst ( InstOrigin(..),
newDicts, newClassDicts,
LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
-import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths,
- tcAddImportedIdInfo, tcInstId, newDFunName
+import TcEnv ( ValueEnv, tcExtendGlobalValEnv,
+ tcExtendTyVarEnvForMeths, TyThing (..),
+ tcAddImportedIdInfo, tcInstId, tcLookupTy,
+ newDFunName, tcExtendTyVarEnv
)
-import TcInstUtil ( InstInfo(..), classDataCon )
-import TcMonoType ( tcHsSigType )
+import TcInstUtil ( InstInfo(..), pprInstInfo, classDataCon, simpleInstInfoTyCon, simpleInstInfoTy )
+import TcMonoType ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
- foldBag, Bag
+ foldBag, Bag, listToBag
)
-import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances )
-import Class ( classBigSig )
+import Class ( Class, DefMeth(..), classBigSig )
import Var ( idName, idType )
import Maybes ( maybeToBool, expectJust )
import MkId ( mkDictFunId )
+import Generics ( validGenericInstanceType )
import Module ( Module )
import Name ( isLocallyDefined )
-import NameSet ( emptyNameSet )
+import NameSet ( emptyNameSet, nameSetToList )
import PrelInfo ( eRROR_ID )
-import PprType ( pprConstraint )
+import PprType ( pprConstraint, pprPred )
import TyCon ( isSynTyCon, tyConDerivings )
import Type ( mkTyVarTys, splitSigmaTy, isTyVarTy,
splitTyConApp_maybe, splitDictTy_maybe,
- splitAlgTyConApp_maybe,
- classesToPreds, classesOfPreds,
- unUsgTy, tyVarsOfTypes
+ splitAlgTyConApp_maybe, classesToPreds, classesOfPreds,
+ unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
+ getClassTys_maybe
)
-import Subst ( mkTopTyVarSubst, substClasses )
+import Subst ( mkTopTyVarSubst, substClasses, substTheta )
import VarSet ( mkVarSet, varSetElems )
-import TysWiredIn ( isFFIArgumentTy, isFFIResultTy )
+import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
+import Name ( Name, NameEnv, extendNameEnv_C, emptyNameEnv,
+ plusNameEnv_C, nameEnvElts )
+import FiniteMap ( mapFM )
+import SrcLoc ( SrcLoc )
+import RnHsSyn -- ( RenamedMonoBinds )
+import VarSet ( varSetElems )
+import UniqFM ( mapUFM )
+import Unique ( Uniquable(..) )
+import BasicTypes ( NewOrData(..) )
+import ErrUtils ( dumpIfSet )
+import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
+ assocElts, extendAssoc_C,
+ equivClassesByUniq, minusList
+ )
+import List ( intersect, (\\) )
import Outputable
\end{code}
and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
\end{enumerate}
+
+%************************************************************************
+%* *
+\subsection{Extracting instance decls}
+%* *
+%************************************************************************
+
+Gather up the instance declarations from their various sources
+
\begin{code}
tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids
-> [RenamedHsDecl]
RenamedHsBinds)
tcInstDecls1 unf_env decls mod fixs rn_name_supply
- = -- Do the ordinary instance declarations
+ = -- (1) Do the ordinary instance declarations
mapNF_Tc (tcInstDecl1 mod unf_env)
[inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
let
decl_inst_info = unionManyBags inst_info_bags
in
- -- Handle "derived" instances; note that we only do derivings
+ -- (2) Instances from "deriving" clauses; note that we only do derivings
-- for things in this module; we ignore deriving decls from
-- interfaces!
- tcDeriving mod fixs rn_name_supply decl_inst_info
- `thenTc` \ (deriv_inst_info, deriv_binds) ->
+ tcDeriving mod fixs rn_name_supply decl_inst_info `thenTc` \ (deriv_inst_info, deriv_binds) ->
+
+ -- (3) Instances from generic class declarations
+ mapTc (getGenericInstances mod)
+ [cl_decl | TyClD cl_decl <- decls, isClassDecl cl_decl] `thenTc` \ cls_inst_info ->
let
- full_inst_info = deriv_inst_info `unionBags` decl_inst_info
+ generic_insts = concat cls_inst_info
+ full_inst_info = deriv_inst_info `unionBags`
+ unionManyBags inst_info_bags `unionBags`
+ (listToBag generic_insts)
in
- returnTc (full_inst_info, deriv_binds)
+ ioToTc (dumpIfSet opt_D_dump_deriv "Generic instances"
+ (vcat (map pprInstInfo generic_insts))) `thenNF_Tc_`
+ (returnTc (full_inst_info, deriv_binds))
+\end{code}
+\begin{code}
tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
-
+-- Deal with a single instance declaration
tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc emptyBag) $
tcHsSigType poly_ty `thenTc` \ poly_ty' ->
let
(tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
- constr = classesOfPreds theta
(clas, inst_tys) = case splitDictTy_maybe dict_ty of
Just ct -> ct
Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
-- contain something illegal in normal Haskell, notably
-- instance CCallable [Char]
scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
- mapNF_Tc scrutiniseInstanceConstraint constr `thenNF_Tc_`
+ mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_`
-- Make the dfun id and return it
newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
- returnNF_Tc (mkDictFunId dfun_name clas tyvars inst_tys constr)
+ returnNF_Tc (mkDictFunId dfun_name clas tyvars inst_tys theta)
Just dfun_name -> -- An interface-file instance declaration
-- Make the dfun id and add info from interface file
let
- dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr
+ dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
in
returnNF_Tc (tcAddImportedIdInfo unf_env dfun_id)
) `thenNF_Tc` \ dfun_id ->
- returnTc (unitBag (InstInfo clas tyvars inst_tys constr dfun_id binds src_loc uprags))
+ returnTc (unitBag (InstInfo clas tyvars inst_tys theta dfun_id binds src_loc uprags))
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Extracting generic instance declaration from class declarations}
+%* *
+%************************************************************************
+
+@getGenericInstances@ extracts the generic instance declarations from a class
+declaration. For exmaple
+
+ class C a where
+ op :: a -> a
+
+ op{ x+y } (Inl v) = ...
+ op{ x+y } (Inr v) = ...
+ op{ x*y } (v :*: w) = ...
+ op{ 1 } Unit = ...
+
+gives rise to the instance declarations
+
+ instance C (x+y) where
+ op (Inl v) = ...
+ op (Inr v) = ...
+
+ instance C (x*y) where
+ op (v :*: w) = ...
+
+ instance C 1 where
+ op Unit = ...
+
+
+\begin{code}
+getGenericInstances :: Module -> RenamedTyClDecl -> TcM s [InstInfo]
+getGenericInstances mod decl@(ClassDecl context class_name tyvar_names
+ fundeps class_sigs def_methods pragmas
+ name_list loc)
+ | null groups
+ = returnTc [] -- The comon case
+
+ | otherwise
+ = recoverNF_Tc (returnNF_Tc []) $
+ tcAddDeclCtxt decl $
+ tcLookupTy class_name `thenTc` \ (AClass clas) ->
+
+ -- Make an InstInfo out of each group
+ mapTc (mkGenericInstance mod clas loc) groups `thenTc` \ inst_infos ->
+
+ -- Check that there is only one InstInfo for each type constructor
+ -- The main way this can fail is if you write
+ -- f {| a+b |} ... = ...
+ -- f {| x+y |} ... = ...
+ -- Then at this point we'll have an InstInfo for each
+ let
+ bad_groups = [group | group <- equivClassesByUniq get_uniq inst_infos,
+ length group > 1]
+ get_uniq inst = getUnique (simpleInstInfoTyCon inst)
+ in
+ mapTc (addErrTc . dupGenericInsts) bad_groups `thenTc_`
+
+ -- Check that there is an InstInfo for each generic type constructor
+ let
+ missing = genericTyCons `minusList` map simpleInstInfoTyCon inst_infos
+ in
+ checkTc (null missing) (missingGenericInstances missing) `thenTc_`
+
+ returnTc inst_infos
+
+ where
+ -- Group the declarations by type pattern
+ groups :: [(RenamedHsType, RenamedMonoBinds)]
+ groups = assocElts (getGenericBinds def_methods)
+
+
+---------------------------------
+getGenericBinds :: RenamedMonoBinds -> Assoc RenamedHsType RenamedMonoBinds
+ -- Takes a group of method bindings, finds the generic ones, and returns
+ -- them in finite map indexed by the type parameter in the definition.
+
+getGenericBinds EmptyMonoBinds = emptyAssoc
+getGenericBinds (AndMonoBinds m1 m2)
+ = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2)
+
+getGenericBinds (FunMonoBind id infixop matches loc)
+ = mapAssoc wrap (foldr add emptyAssoc matches)
+ where
+ add match env = case maybeGenericMatch match of
+ Nothing -> env
+ Just (ty, match') -> extendAssoc_C (++) env (ty, [match'])
+
+ wrap ms = FunMonoBind id infixop ms loc
+
+---------------------------------
+mkGenericInstance :: Module -> Class -> SrcLoc
+ -> (RenamedHsType, RenamedMonoBinds)
+ -> TcM s InstInfo
+
+mkGenericInstance mod clas loc (hs_ty, binds)
+ -- Make a generic instance declaration
+ -- For example: instance (C a, C b) => C (a+b) where { binds }
+
+ = -- Extract the universally quantified type variables
+ tcTyVars (nameSetToList (extractHsTyVars hs_ty))
+ (kcHsSigType hs_ty) `thenTc` \ tyvars ->
+ tcExtendTyVarEnv tyvars $
+
+ -- Type-check the instance type, and check its form
+ tcHsSigType hs_ty `thenTc` \ inst_ty ->
+ checkTc (validGenericInstanceType inst_ty)
+ (badGenericInstanceType binds) `thenTc_`
+
+ -- Make the dictionary function.
+ newDFunName mod clas [inst_ty] loc `thenNF_Tc` \ dfun_name ->
+ let
+ inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
+ inst_tys = [inst_ty]
+ dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
+ in
+
+ returnTc (InstInfo clas tyvars inst_tys inst_theta dfun_id binds loc [])
+ -- The "[]" means "no pragmas"
\end{code}
binds1 `AndMonoBinds` binds2)
\end{code}
-
======= New documentation starts here (Sept 92) ==============
The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc locn $
- -- Check that all the method bindings come from this class
- checkFromThisClass clas monobinds `thenNF_Tc_`
-
-- Instantiate the instance decl with tc-style type variables
tcInstId dfun_id `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
let
- (clas, inst_tys') = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')
-
- origin = InstanceDeclOrigin
+ (clas, inst_tys') = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')
+ origin = InstanceDeclOrigin
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
- dm_ids = [dm_id | (_, dm_id, _) <- op_items]
+ dm_ids = [dm_id | (_, DefMeth dm_id) <- op_items]
+ sel_names = [idName sel_id | (sel_id, _) <- op_items]
-- Instantiate the theta found in the original instance decl
- inst_decl_theta' = substClasses (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
- inst_decl_theta
+ inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
+ inst_decl_theta
- -- Instantiate the super-class context with inst_tys
+ -- Instantiate the super-class context with inst_tys
sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
+
+ -- Find any definitions in monobinds that aren't from the class
+ bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
in
+ -- Check that all the method bindings come from this class
+ mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_`
+
-- Create dictionary Ids from the specified instance contexts.
- newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
- newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
- newClassDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
- newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+ newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
+ newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
+ newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
+ newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
tcExtendGlobalValEnv dm_ids (
-- Default-method Ids may be mentioned in synthesised RHSs
mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
- (classesToPreds inst_decl_theta')
+ inst_decl_theta'
monobinds uprags True)
op_items
)) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
We can also have instances for functions: @instance Foo (a -> b) ...@.
\begin{code}
-scrutiniseInstanceConstraint (clas, tys)
- | all isTyVarTy tys
- || opt_AllowUndecidableInstances = returnNF_Tc ()
- | otherwise = addErrTc (instConstraintErr clas tys)
+scrutiniseInstanceConstraint pred
+ | opt_AllowUndecidableInstances
+ = returnNF_Tc ()
+
+ | Just (clas,tys) <- getClassTys_maybe pred,
+ all isTyVarTy tys
+ = returnNF_Tc ()
+
+ | otherwise
+ = addErrTc (instConstraintErr pred)
scrutiniseInstanceHead clas inst_taus
| -- CCALL CHECK
creturnable_type ty = isFFIResultTy ty
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Error messages}
+%* *
+%************************************************************************
+
+\begin{code}
+tcAddDeclCtxt decl thing_inside
+ = tcAddSrcLoc loc $
+ tcAddErrCtxt ctxt $
+ thing_inside
+ where
+ (name, loc, thing)
+ = case decl of
+ (ClassDecl _ name _ _ _ _ _ _ loc) -> (name, loc, "class")
+ (TySynonym name _ _ loc) -> (name, loc, "type synonym")
+ (TyData NewType _ name _ _ _ _ _ loc _ _) -> (name, loc, "newtype")
+ (TyData DataType _ name _ _ _ _ _ loc _ _) -> (name, loc, "data type")
+
+ ctxt = hsep [ptext SLIT("In the"), text thing,
+ ptext SLIT("declaration for"), quotes (ppr name)]
+\end{code}
+
\begin{code}
-instConstraintErr clas tys
+instConstraintErr pred
= hang (ptext SLIT("Illegal constraint") <+>
- quotes (pprConstraint clas tys) <+>
+ quotes (pprPred pred) <+>
ptext SLIT("in instance context"))
4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
+badGenericInstanceType binds
+ = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
+ nest 4 (ppr binds)]
+
+missingGenericInstances missing
+ = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
+
+
+
+dupGenericInsts inst_infos
+ = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
+ nest 4 (vcat (map (ppr . simpleInstInfoTy) inst_infos)),
+ ptext SLIT("All the type patterns for a generic type constructor must be identical")
+ ]
+
instTypeErr clas tys msg
= sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
nest 4 (parens msg)
module TcInstUtil (
InstInfo(..),
buildInstanceEnv,
- classDataCon
+ instInfoClass, simpleInstInfoTy, simpleInstInfoTyCon, classDataCon,
+ pprInstInfo
) where
#include "HsVersions.h"
import RnHsSyn ( RenamedMonoBinds, RenamedSig )
+import HsTypes ( toHsType )
import CmdLineOpts ( opt_AllowOverlappingInstances )
import TcMonad
import Class ( Class )
import Var ( TyVar, Id, idName )
import Maybes ( MaybeErr(..) )
-import Name ( getSrcLoc, nameModule, isLocallyDefined )
+import Name ( getSrcLoc, nameModule, isLocallyDefined, toRdrName )
import SrcLoc ( SrcLoc )
-import Type ( Type, ClassContext )
+import Type ( Type, ThetaType, splitTyConApp_maybe, mkSigmaTy, mkDictTy )
import PprType ( pprConstraint )
import Class ( classTyCon )
import DataCon ( DataCon )
-import TyCon ( tyConDataCons )
+import TyCon ( TyCon, tyConDataCons )
import Outputable
\end{code}
Class -- Class, k
[TyVar] -- Type variables, tvs
[Type] -- The types at which the class is being instantiated
- ClassContext -- inst_decl_theta: the original context, c, from the
+ ThetaType -- inst_decl_theta: the original context, c, from the
-- instance declaration. It constrains (some of)
-- the TyVars above
Id -- The dfun id
RenamedMonoBinds -- Bindings, b
SrcLoc -- Source location assoc'd with this instance's defn
[RenamedSig] -- User pragmas recorded for generating specialised instances
+
+pprInstInfo (InstInfo clas tvs tys inst_decl_theta _ mbinds _ _)
+ = vcat [ptext SLIT("InstInfo:") <+> ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas tys)),
+ nest 4 (ppr mbinds)]
+
+instInfoClass :: InstInfo -> Class
+instInfoClass (InstInfo clas _ _ _ _ _ _ _) = clas
+
+simpleInstInfoTy :: InstInfo -> Type
+simpleInstInfoTy (InstInfo _ _ [ty] _ _ _ _ _) = ty
+
+simpleInstInfoTyCon :: InstInfo -> TyCon
+ -- Gets the type constructor for a simple instance declaration,
+ -- i.e. one of the form instance (...) => C (T a b c) where ...
+simpleInstInfoTyCon inst
+ = case splitTyConApp_maybe (simpleInstInfoTy inst) of
+ Just (tycon, _) -> tycon
\end{code}
\begin{code}
buildInstanceEnv :: Bag InstInfo -> NF_TcM s InstEnv
-buildInstanceEnv info = foldrNF_Tc addClassInstance emptyInstEnv (bagToList info)
+buildInstanceEnv info = --pprTrace "BuildInstanceEnv" (ppr info)
+ foldrNF_Tc addClassInstance emptyInstEnv (bagToList info)
\end{code}
@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
import TcMonad
-import TcMonoType ( kcHsSigType, kcTyVarScope, newSigTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
+import TcMonoType ( kcHsSigType, tcTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
import Inst ( LIE, plusLIE, emptyLIE, plusLIEs )
import TcEnv ( tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars )
import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig )
-- If there are sig tvs we must be careful *not* to use
-- expected_ty right away, else we'll unify with tyvars free
-- in the envt. So invent a fresh tyvar and use that instead
- newTyVarTy openTypeKind `thenNF_Tc` \ tyvar_ty ->
+ newTyVarTy openTypeKind `thenNF_Tc` \ tyvar_ty ->
-- Extend the tyvar env and check the match itself
- kcTyVarScope sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tv_kinds ->
- newSigTyVars sig_tv_kinds `thenNF_Tc` \ sig_tyvars ->
+ tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars ->
tcExtendTyVarEnv sig_tyvars (tc_match tyvar_ty) `thenTc` \ (pat_ids, match_and_lie) ->
-- Check that the scoped type variables from the patterns
import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkImplicitDataBinds )
+import CoreUnfold ( unfoldingTemplate )
+import Type ( funResultTy, splitForAllTys )
import RnMonad ( RnNameSupply, FixityEnv )
import Bag ( isEmptyBag )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet )
-import Id ( idType, idName )
+import Id ( idType, idName, idUnfolding )
import Module ( pprModuleName, mkThisModule )
import Name ( nameOccName, isLocallyDefined, isGlobalName,
toRdrName, nameEnvElts,
)
+import TyCon ( TyCon, isDataTyCon, tyConName, tyConGenInfo )
import OccName ( isSysOcc )
import TyCon ( TyCon, isClassTyCon )
import Class ( Class )
import UniqSupply ( UniqSupply )
import Maybes ( maybeToBool )
import Util
+import BasicTypes ( EP(..) )
import Bag ( Bag, isEmptyBag )
import Outputable
+
\end{code}
Outside-world interface:
else
Nothing)
-dump_tc results
- = ppr (tc_binds results) $$ pp_rules (tc_rules results)
-
-dump_sigs results -- Print type signatures
- = -- Convert to HsType so that we get source-language style printing
- -- And sort by RdrName
- vcat $ map ppr_sig $ sortLt lt_sig $
- [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results),
- want_sig id
- ]
- where
- lt_sig (n1,_) (n2,_) = n1 < n2
- ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
-
- want_sig id | opt_PprStyle_Debug = True
- | otherwise = isLocallyDefined n &&
- isGlobalName n &&
- not (isSysOcc (nameOccName n))
- where
- n = idName id
-
-pp_rules [] = empty
-pp_rules rs = vcat [ptext SLIT("{-# RULES"),
- nest 4 (vcat (map ppr rs)),
- ptext SLIT("#-}")]
\end{code}
The internal monster:
-- Type-check the type and class decls
tcTyAndClassDecls unf_env decls `thenTc` \ env ->
-
- -- Typecheck the instance decls, includes deriving
tcSetEnv env $
+ -- Typecheck the instance decls, includes deriving
tcInstDecls1 unf_env decls
(mkThisModule mod_name)
fixities rn_name_supply `thenTc` \ (inst_info, deriv_binds) ->
ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Dumping output}
+%* *
+%************************************************************************
+
+\begin{code}
+dump_tc results
+ = vcat [ppr (tc_binds results),
+ pp_rules (tc_rules results),
+ ppr_gen_tycons (tc_tycons results)
+ ]
+
+dump_sigs results -- Print type signatures
+ = -- Convert to HsType so that we get source-language style printing
+ -- And sort by RdrName
+ vcat $ map ppr_sig $ sortLt lt_sig $
+ [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results),
+ want_sig id
+ ]
+ where
+ lt_sig (n1,_) (n2,_) = n1 < n2
+ ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
+
+ want_sig id | opt_PprStyle_Debug = True
+ | otherwise = isLocallyDefined n &&
+ isGlobalName n &&
+ not (isSysOcc (nameOccName n))
+ where
+ n = idName id
+
+ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
+ vcat (map ppr_gen_tycon (filter isLocallyDefined tcs)),
+ ptext SLIT("#-}")
+ ]
+
+-- x&y are now Id's, not CoreExpr's
+ppr_gen_tycon tycon
+ | Just ep <- tyConGenInfo tycon
+ = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
+
+ | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
+
+ppr_ep (EP from to)
+ = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
+ ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
+ ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
+ ]
+ where
+ (_,from_tau) = splitForAllTys (idType from)
+
+pp_rules [] = empty
+pp_rules rs = vcat [ptext SLIT("{-# RULES"),
+ nest 4 (vcat (map ppr rs)),
+ ptext SLIT("#-}")]
+\end{code}
-- Kind checking
kcHsTyVar, kcHsTyVars, mkTyClTyVars,
kcHsType, kcHsSigType, kcHsBoxedSigType, kcHsContext,
- kcTyVarScope, newSigTyVars, mkImmutTyVars,
+ tcTyVars, tcHsTyVars, mkImmutTyVars,
TcSigInfo(..), tcTySig, mkTcSig, maybeSig,
checkSigTyVars, sigCtxt, sigPatCtxt
import VarEnv
import VarSet
import ErrUtils ( Message )
-import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind )
+import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind, tyConName )
import Class ( ClassContext, classArity, classTyCon )
import Name ( Name, isLocallyDefined )
-import TysWiredIn ( mkListTy, mkTupleTy )
+import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon )
import UniqFM ( elemUFM )
import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc )
import Util ( mapAccumL, isSingleton )
import Outputable
+
\end{code}
1b. Apply the kind checker
1c. Zonk the resulting kinds
-The kind checker is passed to kcTyVarScope as an argument.
+The kind checker is passed to tcHsTyVars as an argument.
For example, when we find
(forall a m. m a -> m a)
makes a get kind *, and m get kind *->*. Now we typecheck (m a -> m a)
in an environment that binds a and m suitably.
-The kind checker passed to kcTyVarScope needs to look at enough to
+The kind checker passed to tcHsTyVars needs to look at enough to
establish the kind of the tyvar:
* For a group of type and class decls, it's just the group, not
the rest of the program
a::(*->*)-> *, b::*->*
\begin{code}
-kcTyVarScope :: [HsTyVarBndr Name]
- -> TcM s a -- The kind checker
- -> TcM s [(Name,Kind)]
- -- Do a kind check to find out the kinds of the type variables
- -- Then return a bunch of name-kind pairs, from which to
- -- construct the type variables. We don't return the tyvars
- -- themselves because sometimes we want mutable ones and
- -- sometimes we want immutable ones.
-
-kcTyVarScope [] kind_check = returnTc []
+tcHsTyVars :: [HsTyVarBndr Name]
+ -> TcM s a -- The kind checker
+ -> ([TyVar] -> TcM s b)
+ -> TcM s b
+
+tcHsTyVars [] kind_check thing_inside = thing_inside []
-- A useful short cut for a common case!
-kcTyVarScope tv_names kind_check
+tcHsTyVars tv_names kind_check thing_inside
= kcHsTyVars tv_names `thenNF_Tc` \ tv_names_w_kinds ->
tcExtendKindEnv tv_names_w_kinds kind_check `thenTc_`
- zonkKindEnv tv_names_w_kinds
+ zonkKindEnv tv_names_w_kinds `thenNF_Tc` \ tvs_w_kinds ->
+ let
+ tyvars = mkImmutTyVars tvs_w_kinds
+ in
+ tcExtendTyVarEnv tyvars (thing_inside tyvars)
+
+tcTyVars :: [Name]
+ -> TcM s a -- The kind checker
+ -> TcM s [TyVar]
+tcTyVars [] kind_check = returnTc []
+
+tcTyVars tv_names kind_check
+ = mapNF_Tc newNamedKindVar tv_names `thenTc` \ kind_env ->
+ tcExtendKindEnv kind_env kind_check `thenTc_`
+ zonkKindEnv kind_env `thenNF_Tc` \ tvs_w_kinds ->
+ listNF_Tc [tcNewSigTyVar name kind | (name,kind) <- tvs_w_kinds]
\end{code}
kcHsTyVar :: HsTyVarBndr name -> NF_TcM s (name, TcKind)
kcHsTyVars :: [HsTyVarBndr name] -> NF_TcM s [(name, TcKind)]
-kcHsTyVar (UserTyVar name) = newKindVar `thenNF_Tc` \ kind ->
- returnNF_Tc (name, kind)
+kcHsTyVar (UserTyVar name) = newNamedKindVar name
kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (name, kind)
kcHsTyVars tvs = mapNF_Tc kcHsTyVar tvs
+newNamedKindVar name = newKindVar `thenNF_Tc` \ kind ->
+ returnNF_Tc (name, kind)
+
---------------------------
kcBoxedType :: RenamedHsType -> TcM s ()
-- The type ty must be a *boxed* *type*
---------------------------
kcHsType :: RenamedHsType -> TcM s TcKind
-kcHsType (HsTyVar name)
- = tcLookupTy name `thenTc` \ thing ->
- case thing of
- ATyVar tv -> returnTc (tyVarKind tv)
- ATyCon tc -> returnTc (tyConKind tc)
- AThing k -> returnTc k
- other -> failWithTc (wrongThingErr "type" thing name)
-
+kcHsType (HsTyVar name) = kcTyVar name
kcHsType (HsUsgTy _ ty) = kcHsType ty
kcHsType (HsUsgForAllTy _ ty) = kcHsType ty
kcFunResType ty2 `thenTc_`
returnTc boxedTypeKind
+kcHsType ty@(HsOpTy ty1 op ty2)
+ = kcTyVar op `thenTc` \ op_kind ->
+ kcHsType ty1 `thenTc` \ ty1_kind ->
+ kcHsType ty2 `thenTc` \ ty2_kind ->
+ tcAddErrCtxt (appKindCtxt (ppr ty)) $
+ kcAppKind op_kind ty1_kind `thenTc` \ op_kind' ->
+ kcAppKind op_kind' ty2_kind
+
kcHsType (HsPredTy pred)
= kcHsPred pred `thenTc_`
returnTc boxedTypeKind
kcHsType ty@(HsAppTy ty1 ty2)
- = kcHsType ty1 `thenTc` \ tc_kind ->
- kcHsType ty2 `thenTc` \ arg_kind ->
-
+ = kcHsType ty1 `thenTc` \ tc_kind ->
+ kcHsType ty2 `thenTc` \ arg_kind ->
tcAddErrCtxt (appKindCtxt (ppr ty)) $
- case splitFunTy_maybe tc_kind of
- Just (arg_kind', res_kind)
- -> unifyKind arg_kind arg_kind' `thenTc_`
- returnTc res_kind
-
- Nothing -> newKindVar `thenNF_Tc` \ res_kind ->
- unifyKind tc_kind (mkArrowKind arg_kind res_kind) `thenTc_`
- returnTc res_kind
+ kcAppKind tc_kind arg_kind
kcHsType (HsForAllTy (Just tv_names) context ty)
- = kcHsTyVars tv_names `thenNF_Tc` \ kind_env ->
- tcExtendKindEnv kind_env $
+ = kcHsTyVars tv_names `thenNF_Tc` \ kind_env ->
+ tcExtendKindEnv kind_env $
kcHsContext context `thenTc_`
-- Context behaves like a function type
kcFunResType ty `thenTc_`
returnTc boxedTypeKind
+---------------------------
+kcTyVar name
+ = tcLookupTy name `thenTc` \ thing ->
+ case thing of
+ ATyVar tv -> returnTc (tyVarKind tv)
+ ATyCon tc -> returnTc (tyConKind tc)
+ AThing k -> returnTc k
+ other -> failWithTc (wrongThingErr "type" thing name)
+
+---------------------------
kcFunResType :: RenamedHsType -> TcM s TcKind
-- The only place an unboxed tuple type is allowed
-- is at the right hand end of an arrow
kcFunResType ty = kcHsType ty
+---------------------------
+kcAppKind fun_kind arg_kind
+ = case splitFunTy_maybe fun_kind of
+ Just (arg_kind', res_kind)
+ -> unifyKind arg_kind arg_kind' `thenTc_`
+ returnTc res_kind
+
+ Nothing -> newKindVar `thenNF_Tc` \ res_kind ->
+ unifyKind fun_kind (mkArrowKind arg_kind res_kind) `thenTc_`
+ returnTc res_kind
+
---------------------------
kcHsContext ctxt = mapTc_ kcHsPred ctxt
tcHsType ty2 `thenTc` \ tau_ty2 ->
returnTc (mkFunTy tau_ty1 tau_ty2)
+tcHsType (HsNumTy n)
+ = ASSERT(n== 1)
+ returnTc (mkTyConApp genUnitTyCon [])
+
+tcHsType (HsOpTy ty1 op ty2) =
+ tcHsType ty1 `thenTc` \ tau_ty1 ->
+ tcHsType ty2 `thenTc` \ tau_ty2 ->
+ tc_fun_type op [tau_ty1,tau_ty2]
+
tcHsType (HsAppTy ty1 ty2)
= tc_app ty1 [ty2]
returnTc (mkUsForAllTy uv tc_ty)
tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty)
- = kcTyVarScope tv_names
- (kcHsContext ctxt `thenTc_` kcFunResType ty) `thenTc` \ tv_kinds ->
- let
- forall_tyvars = mkImmutTyVars tv_kinds
- in
- tcExtendTyVarEnv forall_tyvars $
- tcContext ctxt `thenTc` \ theta ->
- tcHsType ty `thenTc` \ tau ->
- let
- -- Check for ambiguity
- -- forall V. P => tau
- -- is ambiguous if P contains generic variables
- -- (i.e. one of the Vs) that are not mentioned in tau
- --
- -- However, we need to take account of functional dependencies
- -- when we speak of 'mentioned in tau'. Example:
- -- class C a b | a -> b where ...
- -- Then the type
- -- forall x y. (C x y) => x
- -- is not ambiguous because x is mentioned and x determines y
- --
- -- NOTE: In addition, GHC insists that at least one type variable
- -- in each constraint is in V. So we disallow a type like
- -- forall a. Eq b => b -> b
- -- even in a scope where b is in scope.
- -- This is the is_free test below.
-
- tau_vars = tyVarsOfType tau
- fds = instFunDepsOfTheta theta
- tvFundep = tyVarFunDep fds
- extended_tau_vars = oclose tvFundep tau_vars
- is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
- not (ct_var `elemUFM` extended_tau_vars)
- is_free ct_var = not (ct_var `elem` forall_tyvars)
-
- check_pred pred = checkTc (not any_ambig) (ambigErr pred full_ty) `thenTc_`
- checkTc (not all_free) (freeErr pred full_ty)
- where
- ct_vars = varSetElems (tyVarsOfPred pred)
- any_ambig = is_source_polytype && any is_ambig ct_vars
- all_free = all is_free ct_vars
-
- -- Check ambiguity only for source-program types, not
- -- for types coming from inteface files. The latter can
- -- legitimately have ambiguous types. Example
- -- class S a where s :: a -> (Int,Int)
- -- instance S Char where s _ = (1,1)
- -- f:: S a => [a] -> Int -> (Int,Int)
- -- f (_::[a]) x = (a*x,b)
- -- where (a,b) = s (undefined::a)
- -- Here the worker for f gets the type
- -- fw :: forall a. S a => Int -> (# Int, Int #)
- --
- -- If the list of tv_names is empty, we have a monotype,
- -- and then we don't need to check for ambiguity either,
- -- because the test can't fail (see is_ambig).
- is_source_polytype = case tv_names of
- (UserTyVar _ : _) -> True
- other -> False
+ = let
+ kind_check = kcHsContext ctxt `thenTc_` kcFunResType ty
in
- mapTc check_pred theta `thenTc_`
- returnTc (mkSigmaTy forall_tyvars theta tau)
+ tcHsTyVars tv_names kind_check $ \ tyvars ->
+ tcContext ctxt `thenTc` \ theta ->
+ tcHsType ty `thenTc` \ tau ->
+ checkAmbiguity full_ty tyvars theta tau `thenTc_`
+ returnTc (mkSigmaTy tyvars theta tau)
+
+ -- Check for ambiguity
+ -- forall V. P => tau
+ -- is ambiguous if P contains generic variables
+ -- (i.e. one of the Vs) that are not mentioned in tau
+ --
+ -- However, we need to take account of functional dependencies
+ -- when we speak of 'mentioned in tau'. Example:
+ -- class C a b | a -> b where ...
+ -- Then the type
+ -- forall x y. (C x y) => x
+ -- is not ambiguous because x is mentioned and x determines y
+ --
+ -- NOTE: In addition, GHC insists that at least one type variable
+ -- in each constraint is in V. So we disallow a type like
+ -- forall a. Eq b => b -> b
+ -- even in a scope where b is in scope.
+ -- This is the is_free test below.
+
+checkAmbiguity full_ty forall_tyvars theta tau
+ = mapTc check_pred theta
+ where
+ tau_vars = tyVarsOfType tau
+ fds = instFunDepsOfTheta theta
+ tvFundep = tyVarFunDep fds
+ extended_tau_vars = oclose tvFundep tau_vars
+
+ is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
+ not (ct_var `elemUFM` extended_tau_vars)
+ is_free ct_var = not (ct_var `elem` forall_tyvars)
+
+ check_pred pred = checkTc (not any_ambig) (ambigErr pred full_ty) `thenTc_`
+ checkTc (not all_free) (freeErr pred full_ty)
+ where
+ ct_vars = varSetElems (tyVarsOfPred pred)
+ all_free = all is_free ct_vars
+ any_ambig = is_source_polytype && any is_ambig ct_vars
+
+ -- Notes on the 'is_source_polytype' test above
+ -- Check ambiguity only for source-program types, not
+ -- for types coming from inteface files. The latter can
+ -- legitimately have ambiguous types. Example
+ -- class S a where s :: a -> (Int,Int)
+ -- instance S Char where s _ = (1,1)
+ -- f:: S a => [a] -> Int -> (Int,Int)
+ -- f (_::[a]) x = (a*x,b)
+ -- where (a,b) = s (undefined::a)
+ -- Here the worker for f gets the type
+ -- fw :: forall a. S a => Int -> (# Int, Int #)
+ --
+ -- If the list of tv_names is empty, we have a monotype,
+ -- and then we don't need to check for ambiguity either,
+ -- because the test can't fail (see is_ambig).
+ is_source_polytype
+ = case full_ty of
+ HsForAllTy (Just (UserTyVar _ : _)) _ _ -> True
+ other -> False
\end{code}
Help functions for type applications
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
+tc_app :: RenamedHsType -> [RenamedHsType] -> TcM s Type
tc_app (HsAppTy ty1 ty2) tys
= tc_app ty1 (ty2:tys)
tc_app ty tys
= tcAddErrCtxt (appKindCtxt pp_app) $
mapTc tcHsType tys `thenTc` \ arg_tys ->
- tc_fun_type ty arg_tys
+ case ty of
+ HsTyVar fun -> tc_fun_type fun arg_tys
+ other -> tcHsType ty `thenTc` \ fun_ty ->
+ returnNF_Tc (mkAppTys fun_ty arg_tys)
where
pp_app = ppr ty <+> sep (map pprParendHsType tys)
-- But not quite; for synonyms it checks the correct arity, and builds a SynTy
-- hence the rather strange functionality.
-tc_fun_type (HsTyVar name) arg_tys
+tc_fun_type name arg_tys
= tcLookupTy name `thenTc` \ thing ->
case thing of
ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
n_args = length arg_tys
other -> failWithTc (wrongThingErr "type constructor" thing name)
-
-tc_fun_type ty arg_tys
- = tcHsType ty `thenTc` \ fun_ty ->
- returnNF_Tc (mkAppTys fun_ty arg_tys)
\end{code}
\begin{code}
mkImmutTyVars :: [(Name,Kind)] -> [TyVar]
-newSigTyVars :: [(Name,Kind)] -> NF_TcM s [TcTyVar]
-
mkImmutTyVars pairs = [mkTyVar name kind | (name, kind) <- pairs]
-newSigTyVars pairs = listNF_Tc [tcNewSigTyVar name kind | (name,kind) <- pairs]
mkTyClTyVars :: Kind -- Kind of the tycon or class
-> [HsTyVarBndr Name]
%************************************************************************
\begin{code}
+tcPat tc_bndr pat@(TypePatIn ty) pat_ty
+ = failWithTc (badTypePat pat)
+
tcPat tc_bndr (VarPatIn name) pat_ty
= tc_bndr name pat_ty `thenTc` \ bndr_id ->
returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
polyPatSig sig_ty
= hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
4 (ppr sig_ty)
+
+badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
\end{code}
import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck )
import TcType ( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy )
import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
-import TcMonoType ( kcTyVarScope, kcHsSigType, tcHsSigType, newSigTyVars, checkSigTyVars )
+import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars )
import TcExpr ( tcExpr )
import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv )
import Inst ( LIE, emptyLIE, plusLIEs, instToId )
newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty ->
-- Deal with the tyvars mentioned in signatures
- -- Yuk to the UserTyVar
- kcTyVarScope (map UserTyVar sig_tvs)
- (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tv_kinds ->
- newSigTyVars sig_tv_kinds `thenNF_Tc` \ sig_tyvars ->
- tcExtendTyVarEnv sig_tyvars (
+ tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars ->
+ tcExtendTyVarEnv sig_tyvars (
-- Ditto forall'd variables
mapNF_Tc new_id vars `thenNF_Tc` \ ids ->
tcExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) ->
tcExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) ->
- returnTc (ids, lhs', rhs', lhs_lie, rhs_lie)
- ) `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
+ returnTc (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie)
+ ) `thenTc` \ (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie) ->
-- Check that LHS has no overloading at all
tcSimplifyToDicts lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) ->
import FiniteMap
import CmdLineOpts ( opt_GlasgowExts )
import Outputable
-import Util
+import ListSetOps ( equivClasses )
+import Util ( zipEqual, mapAccumL )
import List ( partition )
import Maybe ( fromJust )
import Maybes ( maybeToBool )
import TcType ( TcKind, newKindVar, zonkKindEnv )
import TcUnify ( unifyKind )
+import TcInstDcls ( tcAddDeclCtxt )
import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
import Variance ( calcTyConArgVrcs )
import Class ( Class, mkClass, classTyCon )
-import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyCon, mkClassTyCon )
+import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyConRep, mkClassTyCon )
import DataCon ( isNullaryDataCon )
import Var ( varName )
import FiniteMap
unionManyUniqSets, uniqSetToList )
import ErrUtils ( Message )
import Unique ( Unique, Uniquable(..) )
+import HsDecls ( fromClassDeclNameList )
+import Generics ( mkTyConGenInfo )
\end{code}
Dealing with a group
~~~~~~~~~~~~~~~~~~~~
-
Consider a mutually-recursive group, binding
a type constructor T and a class C.
AcyclicSCC decl -> [decl]
CyclicSCC decls -> decls
-tcTyClDecl1 :: ValueEnv -> RenamedTyClDecl -> TcM s (Name, TyThingDetails)
-
tcTyClDecl1 unf_env decl
= tcAddDeclCtxt decl $
if isClassDecl decl then
newKindVar `thenNF_Tc` \ result_kind ->
returnNF_Tc (name, mk_kind arg_kinds result_kind)
-getInitialKind (TyData _ _ name tyvars _ _ _ _ _)
+getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _ _)
= kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
-getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _)
+getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ )
= kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
kcHsType rhs `thenTc` \ rhs_kind ->
unifyKind result_kind rhs_kind
-kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc)
+kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc _ _)
= tcAddDeclCtxt decl $
kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
kcHsContext context `thenTc_`
kcTyClDecl decl@(ClassDecl context class_name
hs_tyvars fundeps class_sigs
- _ _ _ _ _ _ loc)
+ _ _ _ loc)
= tcAddDeclCtxt decl $
kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
kcHsContext context `thenTc_`
argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
buildTyConOrClass is_rec kenv rec_vrcs rec_details
- (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc)
+ (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc name1 name2)
= (tycon_name, ATyCon tycon)
where
- tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
+ tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs
data_cons nconstrs
derived_classes
- flavour is_rec
+ flavour is_rec gen_info
+ gen_info = mkTyConGenInfo tycon name1 name2
DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name
buildTyConOrClass is_rec kenv rec_vrcs rec_details
(ClassDecl context class_name
- tyvar_names fundeps class_sigs def_methods pragmas
- tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
+ tyvar_names fundeps class_sigs def_methods pragmas
+ name_list src_loc)
= (class_name, AClass clas)
where
+ (tycon_name, _, _, _) = fromClassDeclNameList name_list
clas = mkClass class_name tyvars fds
sc_theta sc_sel_ids op_items
tycon
mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
-mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _)
+mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _)
= Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
mk_cls_edges other_decl
= Nothing
----------------------------------------------------
mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
-mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _)
+mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _ _ _)
= (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_cons condecls `unionUniqSets`
get_deriv derivs))
mk_edges decl@(TySynonym name _ rhs _)
= (decl, getUnique name, uniqSetToList (get_ty rhs))
-mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _)
+mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _)
= (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_sigs sigs))
%************************************************************************
\begin{code}
-tcAddDeclCtxt decl thing_inside
- = tcAddSrcLoc loc $
- tcAddErrCtxt ctxt $
- thing_inside
- where
- (name, loc, thing)
- = case decl of
- (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class")
- (TySynonym name _ _ loc) -> (name, loc, "type synonym")
- (TyData NewType _ name _ _ _ _ _ loc) -> (name, loc, "newtype")
- (TyData DataType _ name _ _ _ _ _ loc) -> (name, loc, "data type")
-
- ctxt = hsep [ptext SLIT("In the"), text thing,
- ptext SLIT("declaration for"), quotes (ppr name)]
-\end{code}
-
-\begin{code}
typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
typeCycleErr syn_cycles
import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
import BasicTypes ( NewOrData(..) )
-import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, kcTyVarScope, tcClassContext,
- kcHsContext, kcHsSigType, mkImmutTyVars
+import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, tcHsTyVars, tcClassContext,
+ kcHsContext, kcHsSigType
)
import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcLookupValueByKey, TyThing(..), TyThingDetails(..) )
import TcMonad
import Name ( Name, isLocallyDefined, NamedThing(..) )
import Outputable
import TyCon ( TyCon, isSynTyCon, isNewTyCon,
- tyConDataConsIfAvailable, tyConTyVars
+ tyConDataConsIfAvailable, tyConTyVars, tyConGenIds
)
import Type ( tyVarsOfTypes, splitFunTy, applyTys,
mkTyConApp, mkTyVarTys, mkForAllTys,
import TysWiredIn ( unitTy )
import VarSet ( intersectVarSet, isEmptyVarSet )
import PrelNames ( unpackCStringIdKey, unpackCStringUtf8IdKey )
-import Util ( equivClasses )
+import ListSetOps ( equivClasses )
\end{code}
%************************************************************************
returnTc (tycon_name, SynTyDetails rhs_ty)
-tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_loc)
+tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_loc name1 name2)
= tcLookupTy tycon_name `thenNF_Tc` \ (ATyCon tycon) ->
let
tyvars = tyConTyVars tycon
tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
= tcAddSrcLoc src_loc $
- kcTyVarScope ex_tvs (kcConDetails ex_ctxt details) `thenTc` \ ex_tv_kinds ->
- let
- ex_tyvars = mkImmutTyVars ex_tv_kinds
- in
- tcExtendTyVarEnv ex_tyvars $
+ tcHsTyVars ex_tvs (kcConDetails ex_ctxt details) $ \ ex_tyvars ->
tcClassContext ex_ctxt `thenTc` \ ex_theta ->
case details of
VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys
mkImplicitDataBinds_one tycon
= mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
let
- unf_ids = sel_ids ++ data_con_wrapper_ids
- all_ids = map dataConId data_cons ++ unf_ids
+ unf_ids = sel_ids ++ data_con_wrapper_ids ++ gen_ids
+ all_ids = map dataConId data_cons ++ unf_ids
-- For the locally-defined things
-- we need to turn the unfoldings inside the selector Ids into bindings,
data_cons = tyConDataConsIfAvailable tycon
-- Abstract types mean we don't bring the
-- data cons into scope, which should be fine
-
+ gen_ids = tyConGenIds tycon
data_con_wrapper_ids = map dataConWrapId data_cons
fields = [ (con, field) | con <- data_cons,
import Var ( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar )
-- others:
-import TcMonad
+import TcMonad -- TcType, amongst others
import TysWiredIn ( voidTy )
import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName,
\begin{code}
module Class (
Class, ClassOpItem, ClassPred, ClassContext, FunDep,
+ DefMeth (..),
mkClass, classTyVars, classArity,
classKey, className, classSelIds, classTyCon,
type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where ...
-- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
-type ClassOpItem = (Id, -- Selector function; contains unfolding
- Id, -- Default methods
- Bool) -- True <=> an explicit default method was
- -- supplied in the class decl
+type ClassOpItem = (Id, DefMeth Id)
+ -- Selector function; contains unfolding
+ -- Default-method info
+
+data DefMeth id = NoDefMeth -- No default method
+ | DefMeth id -- A polymorphic default method (named id)
+ | GenDefMeth -- A generic default method
+ deriving Eq
\end{code}
The @mkClass@ function fills in the indirect superclasses.
-- Could memoise this
classSelIds (Class {classSCSels = sc_sels, classOpStuff = op_stuff})
- = sc_sels ++ [op_sel | (op_sel, _, _) <- op_stuff]
+ = sc_sels ++ [op_sel | (op_sel, _) <- op_stuff]
classTvsFds c
= (classTyVars c, classFunDeps c)
--- /dev/null
+__interface Generics 1 0 where
+__export Generics mkTyConGenInfo ;
+
+1 mkTyConGenInfo :: TyCon.TyCon -> Name.Name -> Name.Name -> PrelMaybe.Maybe (BasicTypes.EP Var.Id) ;
--- /dev/null
+\begin{code}
+module Generics ( mkTyConGenInfo, mkGenericRhs,
+ validGenericInstanceType, validGenericMethodType
+ ) where
+
+
+import CmdLineOpts ( opt_GlasgowExts )
+import RnHsSyn ( RenamedHsExpr )
+import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch )
+
+import Type ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes,
+ mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys,
+ mkFunTy, funResultTy, isTyVarTy, splitForAllTys,
+ splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon
+ )
+
+import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId )
+
+import TyCon ( TyCon, tyConTyVars, tyConDataConsIfAvailable,
+ tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
+ )
+import Name ( Name, mkSysLocalName )
+import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..),
+ mkConApp, Alt, Bind (..), mkTyApps, mkVarApps )
+import BasicTypes ( RecFlag(..), EP(..), Boxity(..) )
+import Var ( TyVar )
+import VarSet ( isEmptyVarSet )
+import Id ( Id, mkTemplateLocal, mkTemplateLocals, idType, idName,
+ mkTemplateLocalsNum, mkVanillaId, mkId
+ )
+import TysWiredIn ( genericTyCons,
+ genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
+ inlDataCon, crossTyCon, crossDataCon
+ )
+import IdInfo ( vanillaIdInfo, setUnfoldingInfo )
+import CoreUnfold ( mkTopUnfolding )
+
+import Unique ( Uniquable(..), mkBuiltinUnique )
+import SrcLoc ( mkBuiltinSrcLoc )
+import Maybes ( maybeToBool, expectJust )
+import Outputable
+
+#include "HsVersions.h"
+\end{code}
+
+Roadmap of what's where in the Generics work.
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Parser
+No real checks.
+
+RnSource.rnHsType
+ Checks that HsNumTy has a "1" in it.
+
+TcInstDcls.mkGenericInstance:
+ Checks for invalid type patterns, such as f {| Int |}
+
+TcClassDcl.tcClassSig
+ Checks for a method type that is too complicated;
+ e.g. has for-alls or lists in it
+ We could lift this restriction
+
+TcClassDecl.mkDefMethRhs
+ Checks that the instance type is simple, in an instance decl
+ where we let the compiler fill in a generic method.
+ e.g. instance C (T Int)
+ is not valid if C has generic methods.
+
+TcClassDecl.checkGenericClassIsUnary
+ Checks that we don't have generic methods in a multi-parameter class
+
+TcClassDecl.checkDefaultBinds
+ Checks that all the equations for a method in a class decl
+ are generic, or all are non-generic
+
+
+
+Checking that the type constructors which are present in Generic
+patterns (not Unit, this is done differently) is done in mk_inst_info
+(TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
+HsOpTy is tied to Generic definitions which is not a very good design
+feature, indeed a bug. However, the check is easy to move from
+tcHsType back to mk_inst_info and everything will be fine. Also see
+bug #5.
+
+Generics.lhs
+
+Making generic information to put into a tycon. Constructs the
+representation type, which, I think, are not used later. Perhaps it is
+worth removing them from the GI datatype. Although it does get used in
+the construction of conversion functions (internally).
+
+TyCon.lhs
+
+Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
+
+TysWiredIn.lhs
+
+Defines generic and other type and data constructors.
+
+This is sadly incomplete, but will be added to.
+
+
+Bugs & shortcomings of existing implementation:
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+2. Another pretty big bug I dscovered at the last minute when I was
+testing the code is that at the moment the type variable of the class
+is scoped over the entire declaration, including the patterns. For
+instance, if I have the following code,
+
+class Er a where
+ ...
+ er {| Plus a b |} (Inl x) (Inl y) = er x y
+ er {| Plus a b |} (Inr x) (Inr y) = er x y
+ er {| Plus a b |} _ _ = False
+
+and I print out the types of the generic patterns, I get the
+following. Note that all the variable names for "a" are the same,
+while for "b" they are all different.
+
+check_ty
+ [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
+ std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
+ std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
+
+This is a bug as if I change the code to
+
+ er {| Plus c b |} (Inl x) (Inl y) = er x y
+
+all the names come out to be different.
+
+Thus, all the types (Plus a b) come out to be different, so I cannot
+compare them and test whether they are all the same and thus cannot
+return an error if the type variables are different.
+
+Temporary fix/hack. I am not checking for this, I just assume they are
+the same, see line "check_ty = True" in TcInstDecls. When we resolve
+the issue with variables, though - I assume that we will make them to
+be the same in all the type patterns, jus uncomment the check and
+everything should work smoothly.
+
+Hence, I have also left the rather silly construction of:
+* extracting all the type variables from all the types
+* putting them *all* into the environment
+* typechecking all the types
+* selecting one of them and using it as the instance_ty.
+
+(the alternative is to make sure that all the types are the same,
+taking one, extracting its variables, putting them into the environment,
+type checking it, using it as the instance_ty)
+
+6. What happens if we do not supply all of the generic patterns? At
+the moment, the compiler crashes with an error message "Non-exhaustive
+patterns in a generic declaration"
+
+
+What has not been addressed:
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Contexts. In the generated instance declarations for the 3 primitive
+type constructors, we need contexts. It is unclear what those should
+be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
+
+Type application. We have type application in expressions
+(essentially) on the lhs of an equation. Do we want to allow it on the
+RHS?
+
+Scoping of type variables in a generic definition. At the moment, (see
+TcInstDecls) we extract the type variables inside the type patterns
+and add them to the environment. See my bug #2 above. This seems pretty
+important.
+
+
+
+%************************************************************************
+%* *
+\subsection{Getting the representation type out}
+%* *
+%************************************************************************
+
+\begin{code}
+validGenericInstanceType :: Type -> Bool
+ -- Checks for validity of the type pattern in a generic
+ -- declaration. It's ok to have
+ -- f {| a + b |} ...
+ -- but it's not OK to have
+ -- f {| a + Int |}
+
+validGenericInstanceType inst_ty
+ = case splitTyConApp_maybe inst_ty of
+ Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons
+ Nothing -> False
+
+validGenericMethodType :: Type -> Bool
+ -- At the moment we only allow method types built from
+ -- * type variables
+ -- * function arrow
+ -- * boxed tuples
+ -- * an arbitrary type not involving the class type variables
+validGenericMethodType ty = valid ty
+
+valid ty
+ | isTyVarTy ty = True
+ | not (null arg_tys) = all valid arg_tys && valid res_ty
+ | no_tyvars_in_ty = True
+ | otherwise = isBoxedTupleTyCon tc && all valid tys
+ where
+ (arg_tys, res_ty) = splitFunTys ty
+ no_tyvars_in_ty = isEmptyVarSet (tyVarsOfType ty)
+ Just (tc,tys) = splitTyConApp_maybe ty
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Generating representation types}
+%* *
+%************************************************************************
+
+\begin{code}
+mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
+-- mkTyConGenInfo is called twice
+-- once from TysWiredIn for Tuples
+-- once the typechecker TcTyDecls
+-- to generate generic types and conversion functions for all datatypes.
+--
+-- Must only be called with an algebraic type.
+--
+-- The two names are the names constructed by the renamer
+-- for the fromT and toT conversion functions.
+
+mkTyConGenInfo tycon from_name to_name
+ | not opt_GlasgowExts
+ = Nothing
+
+ | null datacons -- Abstractly imported types don't have
+ = Nothing -- to/from operations, (and should not need them)
+
+ -- If any of the constructor has an unboxed type as argument
+ -- then we can't build the embedding-projection pair, because
+ -- it relies on instantiating *polymorphic* sum and product types
+ -- at the argument types of the constructors
+ | any (any isUnLiftedType . dataConOrigArgTys) datacons
+ = Nothing
+
+ | otherwise
+ = Just (EP { fromEP = mkId from_name from_ty from_id_info,
+ toEP = mkId to_name to_ty to_id_info })
+ where
+ tyvars = tyConTyVars tycon -- [a, b, c]
+ datacons = tyConDataConsIfAvailable tycon -- [C, D]
+ tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
+ tyvar_tys = mkTyVarTys tyvars
+
+ from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
+ to_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+
+ from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
+ to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
+
+ (from_fn, to_fn, rep_ty)
+ | isNewTyCon tycon
+ = ( mkLams tyvars $ Lam x $ Note (Coerce newrep_ty tycon_ty) (Var x),
+ Var (dataConWrapId the_datacon),
+ newrep_ty )
+
+ | otherwise
+ = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts,
+ mkLams tyvars $ Lam rep_var to_inner,
+ idType rep_var )
+
+ -- x :: T a b c
+ x = mkTemplateLocal 1 tycon_ty
+
+ ----------------------
+ -- Newtypes only
+ [the_datacon] = datacons
+ newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys
+
+ ----------------------
+ -- Non-newtypes only
+ -- Recurse over the sum first
+ -- The "2" is the first free unique
+ (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons
+
+
+
+----------------------------------------------------
+-- Dealing with sums
+----------------------------------------------------
+mk_sum_stuff :: Int -- Base for generating unique names
+ -> [TyVar] -- Type variables over which the tycon is abstracted
+ -> [DataCon] -- The data constructors
+ -> ([Alt Id], CoreExpr, Id)
+
+-- For example, given
+-- data T = C | D Int Int Int
+--
+-- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
+-- case cd of { Inl u -> C;
+-- Inr abc -> case abc of { a :*: bc ->
+-- case bc of { b :*: c ->
+-- D a b c }} },
+-- cd)
+
+mk_sum_stuff i tyvars [datacon]
+ = ([from_alt], to_body_fn app_exp, rep_var)
+ where
+ types = dataConOrigArgTys datacon
+ datacon_vars = mkTemplateLocalsNum i types
+ new_i = i + length types
+ app_exp = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars)
+ from_alt = (DataAlt datacon, datacon_vars, from_alt_rhs)
+
+ (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
+
+mk_sum_stuff i tyvars datacons
+ = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
+ Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
+ (DataAlt inrDataCon, [r_rep_var], r_to_body)],
+ rep_var)
+ where
+ (l_datacons, r_datacons) = splitInHalf datacons
+ (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons
+ (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons
+ rep_tys = [idType l_rep_var, idType r_rep_var]
+ rep_ty = mkTyConApp plusTyCon rep_tys
+ rep_var = mkTemplateLocal i rep_ty
+
+ wrap :: DataCon -> [Alt Id] -> [Alt Id]
+ -- Wrap an application of the Inl or Inr constructor round each alternative
+ wrap datacon alts
+ = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
+ where
+ datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
+
+
+-- This constructs the c_of datatype from a DataCon and a Type
+-- The identity function at the moment.
+cOfConstr :: DataCon -> Type -> Type
+cOfConstr y z = z
+
+
+----------------------------------------------------
+-- Dealing with products
+----------------------------------------------------
+mk_prod_stuff :: Int -- Base for unique names
+ -> [Id] -- arg-ids; args of the original user-defined constructor
+ -- They are bound enclosing from_rhs
+ -- Please bind these in the to_body_fn
+ -> (Int, -- Depleted unique-name supply
+ CoreExpr, -- from-rhs: puts together the representation from the arg_ids
+ CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
+ Id) -- The rep-id; please bind this to the representation
+
+-- For example:
+-- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
+-- \x -> case abc of { a :*: bc ->
+-- case bc of { b :*: c ->
+-- x,
+-- abc )
+
+-- We need to use different uqiques in the branches
+-- because the returned to_body_fns are nested.
+-- Hence the returned unqique-name supply
+
+mk_prod_stuff i [] -- Unit case
+ = (i,
+ Var (dataConWrapId genUnitDataCon),
+ \x -> x,
+ mkTemplateLocal i (mkTyConApp genUnitTyCon []))
+
+mk_prod_stuff i [arg_var] -- Singleton case
+ = (i, Var arg_var, \x -> x, arg_var)
+
+mk_prod_stuff i arg_vars -- Two or more
+ = (r_i,
+ mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
+ \x -> Case (Var rep_var) rep_var
+ [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
+ rep_var)
+ where
+ (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
+ (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
+ (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars
+ rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
+ rep_tys = [idType l_rep_var, idType r_rep_var]
+\end{code}
+
+A little utility function
+
+\begin{code}
+splitInHalf :: [a] -> ([a],[a])
+splitInHalf list = (left, right)
+ where
+ half = length list `div` 2
+ left = take half list
+ right = drop half list
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Generating the RHS of a generic default method}
+%* *
+%************************************************************************
+
+Generating the Generic default method. Uses the bimaps to generate the
+actual method. All of this is rather incomplete, but it would be nice
+to make even this work.
+
+\begin{code}
+mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
+mkGenericRhs sel_id tyvar tycon
+ = HsApp (toEP bimap) (HsVar (idName sel_id))
+ where
+ -- Initialising the "Environment" with the from/to functions
+ -- on the datatype (actually tycon) in question
+ Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
+ ep = EP (HsVar (idName from)) (HsVar (idName to))
+
+ -- Takes out the ForAll and the Class rstrictions in front of the
+ -- type of the method.
+ (_,_,op_ty) = splitSigmaTy (idType sel_id)
+
+ -- Now we probably have a tycon in front
+ -- of us, quite probably a FunTyCon.
+ bimap = generate_bimap (tyvar, ep) op_ty
+
+-- EP is the environment of to/from bimaps, but as we only have one type
+-- variable at the moment, there is only one EP.
+
+-------------------
+generate_bimap :: (TyVar, EP RenamedHsExpr) -> Type -> EP RenamedHsExpr
+-- Top level case - splitting the TyCon.
+generate_bimap (tv,ep) ty | isTyVarTy ty = ASSERT( getTyVar "Generics.generate_bimap" ty == tv) ep
+ | otherwise = bimapApp (tv,ep) (splitTyConApp_maybe ty)
+
+-------------------
+bimapApp :: (TyVar, EP RenamedHsExpr) -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
+bimapApp ep Nothing = panic "TcClassDecl: Type Application!"
+bimapApp ep (Just (tycon, ty_args))
+ | tycon == funTyCon = bimapArrow arg_eps
+ | isBoxedTupleTyCon tycon = bimapTuple arg_eps
+ | otherwise = -- Otherwise validGenericMethodType will
+ -- have checked that the type is a constant type
+ ASSERT( isEmptyVarSet (tyVarsOfTypes ty_args) )
+ EP idexpr idexpr
+ where
+ arg_eps = map (generate_bimap ep) ty_args
+
+-------------------
+bimapArrow [ep1, ep2]
+ = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
+ toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
+ where
+ from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
+ to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
+
+-------------------
+bimapTuple eps
+ = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
+ toEP = mk_hs_lam [tuple_pat] to_body }
+ where
+ names = take (length eps) genericNames
+ tuple_pat = TuplePatIn (map VarPatIn names) Boxed
+ eps_w_names = eps `zip` names
+ to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
+ from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
+
+-------------------
+genericNames :: [Name]
+genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
+(g1:g2:g3:_) = genericNames
+
+mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing mkBuiltinSrcLoc))
+idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)
+\end{code}
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
isRecursiveTyCon, newTyConRep,
- mkAlgTyCon,
+ mkAlgTyConRep, --mkAlgTyCon,
mkClassTyCon,
mkFunTyCon,
mkPrimTyCon,
setTyConName,
+ tyConName,
tyConKind,
tyConUnique,
tyConTyVars,
maybeTyConSingleCon,
- matchesTyCon
+ matchesTyCon,
+
+ -- Generics
+ tyConGenIds, tyConGenInfo
) where
#include "HsVersions.h"
import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon )
+
import Class ( Class, ClassContext )
-import Var ( TyVar )
-import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed )
+import Var ( TyVar, Id )
+import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..),
+ isBoxed, EP(..) )
import Name ( Name, nameUnique, NamedThing(getName) )
import PrelNames ( Unique, Uniquable(..), anyBoxConKey )
import PrimRep ( PrimRep(..), isFollowableRep )
algTyConRec :: RecFlag, -- Tells whether the data type is part of
-- a mutually-recursive group or not
+ genInfo :: Maybe (EP Id), -- Convert T <-> Tring
+ -- Some TyCons don't have it;
+ -- e.g. the TyCon for a Class dictionary,
+ -- and TyCons with unboxed arguments
+
algTyConClass :: Bool -- True if this tycon comes from a class declaration
}
tyConArity :: Arity,
tyConBoxed :: Boxity,
tyConTyVars :: [TyVar],
- dataCon :: DataCon
+ dataCon :: DataCon,
+ genInfo :: Maybe (EP Id) -- Generic type and conv funs
}
| SynTyCon {
tyConKind = kind,
tyConArity = 2
}
-
-mkAlgTyCon name kind tyvars theta argvrcs cons ncons derivs flavour rec
+
+tyConGenInfo :: TyCon -> Maybe (EP Id)
+tyConGenInfo (AlgTyCon { genInfo = info }) = info
+tyConGenInfo (TupleTyCon { genInfo = info }) = info
+tyConGenInfo other = Nothing
+
+tyConGenIds :: TyCon -> [Id]
+-- Returns the generic-programming Ids; these Ids need bindings
+tyConGenIds tycon = case tyConGenInfo tycon of
+ Nothing -> []
+ Just (EP from to) -> [from,to]
+
+-- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
+-- but now you also have to pass in the generic information about the type
+-- constructor - you can get hold of it easily (see Generics module)
+mkAlgTyConRep name kind tyvars theta argvrcs cons ncons derivs flavour rec
+ gen_info
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
algTyConDerivings = derivs,
algTyConClass = False,
algTyConFlavour = flavour,
- algTyConRec = rec
+ algTyConRec = rec,
+ genInfo = gen_info
}
mkClassTyCon name kind tyvars argvrcs con clas flavour
algTyConDerivings = [],
algTyConClass = True,
algTyConFlavour = flavour,
- algTyConRec = NonRecursive
+ algTyConRec = NonRecursive,
+ genInfo = Nothing
}
-mkTupleTyCon name kind arity tyvars con boxed
+mkTupleTyCon name kind arity tyvars con boxed gen_info
= TupleTyCon {
tyConUnique = nameUnique name,
tyConName = name,
tyConArity = arity,
tyConBoxed = boxed,
tyConTyVars = tyvars,
- dataCon = con
+ dataCon = con,
+ genInfo = gen_info
}
mkPrimTyCon name kind arity arg_vrcs rep
}
setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name}
+
\end{code}
\begin{code}
getUnique tc = tyConUnique tc
instance Outputable TyCon where
- ppr tc = ppr (getName tc)
+ ppr tc = ppr (getName tc)
instance NamedThing TyCon where
getName = tyConName
uniq1 = tyConUnique tc1
uniq2 = tyConUnique tc2
\end{code}
+
+
+
split orig_ty ty ts = (reverse ts, orig_ty)
\end{code}
+
isSigmaType returns true of any qualified type. It doesn't *necessarily* have
any foralls. E.g.
f :: (?x::Int) => Int -> Int
Free variables of a type
~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tyVarsOfType :: Type -> TyVarSet
+tyVarsOfType :: Type -> TyVarSet
tyVarsOfType (TyVarTy tv) = unitVarSet tv
tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
import Name ( Name, Provenance(..), ExportFlag(..),
mkWiredInTyConName, mkGlobalName, mkKindOccFS, tcName,
)
+import OccName ( mkSrcOccFS, tcName )
import TyCon ( TyCon, KindCon,
mkFunTyCon, mkKindCon, mkSuperKindCon,
)
We define a few wired-in type constructors here to avoid module knots
\begin{code}
-funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("(->)") funTyCon
+funTyConName = mkWiredInTyConName funTyConKey pREL_GHC (mkSrcOccFS tcName SLIT("(->)")) funTyCon
funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind)
\end{code}
\begin{code}
module ListSetOps (
- unionLists,
- --UNUSED: intersectLists,
- minusList
+ unionLists, minusList,
+
+ -- Association lists
+ Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
+ emptyAssoc, unitAssoc, mapAssoc, plusAssoc_C, extendAssoc_C,
+ mkLookupFun, assocElts,
+
+ -- Duplicate handling
+ hasNoDups, runs, removeDups, removeDupsEq,
+ equivClasses, equivClassesByUniq
) where
#include "HsVersions.h"
-import Util ( isn'tIn )
+import Outputable
+import Unique ( Unique )
+import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
+import Util ( isn'tIn, isIn, mapAccumR, sortLt )
import List ( union )
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Treating lists as sets}
+%* *
+%************************************************************************
+
\begin{code}
unionLists :: (Eq a) => [a] -> [a] -> [a]
unionLists = union
\end{code}
Everything in the first list that is not in the second list:
+
\begin{code}
minusList :: (Eq a) => [a] -> [a] -> [a]
minusList xs ys = [ x | x <- xs, x `not_elem` ys]
where
not_elem = isn'tIn "minusList"
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Utils-assoc]{Association lists}
+%* *
+%************************************************************************
+
+Inefficient finite maps based on association lists and equality.
+
+\begin{code}
+type Assoc a b = [(a,b)] -- A finite mapping based on equality and association lists
+
+emptyAssoc :: Assoc a b
+unitAssoc :: a -> b -> Assoc a b
+assocElts :: Assoc a b -> [(a,b)]
+assoc :: (Eq a) => String -> Assoc a b -> a -> b
+assocDefault :: (Eq a) => b -> Assoc a b -> a -> b
+assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
+assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b
+assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b
+mapAssoc :: (b -> c) -> Assoc a b -> Assoc a c
+extendAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> (a,b) -> Assoc a b
+plusAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> Assoc a b -> Assoc a b
+ -- combining fn takes (old->new->result)
+
+emptyAssoc = []
+unitAssoc a b = [(a,b)]
+assocElts xs = xs
+
+assocDefaultUsing eq deflt ((k,v) : rest) key
+ | k `eq` key = v
+ | otherwise = assocDefaultUsing eq deflt rest key
+
+assocDefaultUsing eq deflt [] key = deflt
+assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
+assocDefault deflt list key = assocDefaultUsing (==) deflt list key
+assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
+
+assocMaybe alist key
+ = lookup alist
+ where
+ lookup [] = Nothing
+ lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
+
+mapAssoc f alist = [(key, f val) | (key,val) <- alist]
+
+plusAssoc_C combine [] new = new -- Shortcut for common case
+plusAssoc_C combine old new = foldl (extendAssoc_C combine) old new
+
+extendAssoc_C combine old_list (new_key, new_val)
+ = go old_list
+ where
+ go [] = [(new_key, new_val)]
+ go ((old_key, old_val) : old_list)
+ | new_key == old_key = ((old_key, old_val `combine` new_val) : old_list)
+ | otherwise = (old_key, old_val) : go old_list
\end{code}
+
+
+@mkLookupFun eq alist@ is a function which looks up
+its argument in the association list @alist@, returning a Maybe type.
+@mkLookupFunDef@ is similar except that it is given a value to return
+on failure.
+
+\begin{code}
+mkLookupFun :: (key -> key -> Bool) -- Equality predicate
+ -> [(key,val)] -- The assoc list
+ -> key -- The key
+ -> Maybe val -- The corresponding value
+
+mkLookupFun eq alist s
+ = case [a | (s',a) <- alist, s' `eq` s] of
+ [] -> Nothing
+ (a:_) -> Just a
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Utils-dups]{Duplicate-handling}
+%* *
+%************************************************************************
+
+\begin{code}
+hasNoDups :: (Eq a) => [a] -> Bool
+
+hasNoDups xs = f [] xs
+ where
+ f seen_so_far [] = True
+ f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
+ False
+ else
+ f (x:seen_so_far) xs
+
+ is_elem = isIn "hasNoDups"
+\end{code}
+
+\begin{code}
+equivClasses :: (a -> a -> Ordering) -- Comparison
+ -> [a]
+ -> [[a]]
+
+equivClasses cmp stuff@[] = []
+equivClasses cmp stuff@[item] = [stuff]
+equivClasses cmp items
+ = runs eq (sortLt lt items)
+ where
+ eq a b = case cmp a b of { EQ -> True; _ -> False }
+ lt a b = case cmp a b of { LT -> True; _ -> False }
+\end{code}
+
+The first cases in @equivClasses@ above are just to cut to the point
+more quickly...
+
+@runs@ groups a list into a list of lists, each sublist being a run of
+identical elements of the input list. It is passed a predicate @p@ which
+tells when two elements are equal.
+
+\begin{code}
+runs :: (a -> a -> Bool) -- Equality
+ -> [a]
+ -> [[a]]
+
+runs p [] = []
+runs p (x:xs) = case (span (p x) xs) of
+ (first, rest) -> (x:first) : (runs p rest)
+\end{code}
+
+\begin{code}
+removeDups :: (a -> a -> Ordering) -- Comparison function
+ -> [a]
+ -> ([a], -- List with no duplicates
+ [[a]]) -- List of duplicate groups. One representative from
+ -- each group appears in the first result
+
+removeDups cmp [] = ([], [])
+removeDups cmp [x] = ([x],[])
+removeDups cmp xs
+ = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
+ (xs', dups) }
+ where
+ collect_dups dups_so_far [x] = (dups_so_far, x)
+ collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
+
+removeDupsEq :: Eq a => [a] -> ([a], [[a]])
+-- Same, but with only equality
+-- It's worst case quadratic, but we only use it on short lists
+removeDupsEq [] = ([], [])
+removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs)
+ where
+ (ys,zs) = removeDupsEq (filter (/= x) xs)
+removeDupsEq (x:xs) | otherwise = (x:ys, zs)
+ where
+ (ys,zs) = removeDupsEq xs
+\end{code}
+
+
+\begin{code}
+equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
+ -- NB: it's *very* important that if we have the input list [a,b,c],
+ -- where a,b,c all have the same unique, then we get back the list
+ -- [a,b,c]
+ -- not
+ -- [c,b,a]
+ -- Hence the use of foldr, plus the reversed-args tack_on below
+equivClassesByUniq get_uniq xs
+ = eltsUFM (foldr add emptyUFM xs)
+ where
+ add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
+ tack_on old new = new++old
+\end{code}
+
+
expectJust,
maybeToBool,
- assocMaybe,
- mkLookupFun, mkLookupFunDef,
-
failMaB,
failMaybe,
seqMaybe,
Nothing `orElse` y = y
\end{code}
-Lookup functions
-~~~~~~~~~~~~~~~~
-
-@assocMaybe@ looks up in an assocation list, returning
-@Nothing@ if it fails.
-
-\begin{code}
-assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b
-
-assocMaybe alist key
- = lookup alist
- where
- lookup [] = Nothing
- lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
-\end{code}
-
-@mkLookupFun eq alist@ is a function which looks up
-its argument in the association list @alist@, returning a Maybe type.
-@mkLookupFunDef@ is similar except that it is given a value to return
-on failure.
-
-\begin{code}
-mkLookupFun :: (key -> key -> Bool) -- Equality predicate
- -> [(key,val)] -- The assoc list
- -> key -- The key
- -> Maybe val -- The corresponding value
-
-mkLookupFun eq alist s
- = case [a | (s',a) <- alist, s' `eq` s] of
- [] -> Nothing
- (a:_) -> Just a
-
-mkLookupFunDef :: (key -> key -> Bool) -- Equality predicate
- -> [(key,val)] -- The assoc list
- -> val -- Value to return on failure
- -> key -- The key
- -> val -- The corresponding value
-
-mkLookupFunDef eq alist deflt s
- = case [a | (s',a) <- alist, s' `eq` s] of
- [] -> deflt
- (a:_) -> a
-\end{code}
%************************************************************************
%* *
-- for-loop
nTimes,
- -- association lists
- assoc, assocUsing, assocDefault, assocDefaultUsing,
-
- -- duplicate handling
- hasNoDups, equivClasses, runs, removeDups, removeDupsEq, equivClassesByUniq,
-
-- sorting
IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
sortLt,
%************************************************************************
%* *
-\subsection[Utils-assoc]{Association lists}
-%* *
-%************************************************************************
-
-See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
-
-\begin{code}
-assoc :: (Eq a) => String -> [(a, b)] -> a -> b
-assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
-assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
-assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
-
-assocDefaultUsing eq deflt ((k,v) : rest) key
- | k `eq` key = v
- | otherwise = assocDefaultUsing eq deflt rest key
-
-assocDefaultUsing eq deflt [] key = deflt
-
-assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
-assocDefault deflt list key = assocDefaultUsing (==) deflt list key
-assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-dups]{Duplicate-handling}
-%* *
-%************************************************************************
-
-\begin{code}
-hasNoDups :: (Eq a) => [a] -> Bool
-
-hasNoDups xs = f [] xs
- where
- f seen_so_far [] = True
- f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
- False
- else
- f (x:seen_so_far) xs
-
- is_elem = isIn "hasNoDups"
-\end{code}
-
-\begin{code}
-equivClasses :: (a -> a -> Ordering) -- Comparison
- -> [a]
- -> [[a]]
-
-equivClasses cmp stuff@[] = []
-equivClasses cmp stuff@[item] = [stuff]
-equivClasses cmp items
- = runs eq (sortLt lt items)
- where
- eq a b = case cmp a b of { EQ -> True; _ -> False }
- lt a b = case cmp a b of { LT -> True; _ -> False }
-\end{code}
-
-The first cases in @equivClasses@ above are just to cut to the point
-more quickly...
-
-@runs@ groups a list into a list of lists, each sublist being a run of
-identical elements of the input list. It is passed a predicate @p@ which
-tells when two elements are equal.
-
-\begin{code}
-runs :: (a -> a -> Bool) -- Equality
- -> [a]
- -> [[a]]
-
-runs p [] = []
-runs p (x:xs) = case (span (p x) xs) of
- (first, rest) -> (x:first) : (runs p rest)
-\end{code}
-
-\begin{code}
-removeDups :: (a -> a -> Ordering) -- Comparison function
- -> [a]
- -> ([a], -- List with no duplicates
- [[a]]) -- List of duplicate groups. One representative from
- -- each group appears in the first result
-
-removeDups cmp [] = ([], [])
-removeDups cmp [x] = ([x],[])
-removeDups cmp xs
- = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
- (xs', dups) }
- where
- collect_dups dups_so_far [x] = (dups_so_far, x)
- collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
-
-removeDupsEq :: Eq a => [a] -> ([a], [[a]])
--- Same, but with only equality
--- It's worst case quadratic, but we only use it on short lists
-removeDupsEq [] = ([], [])
-removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs)
- where
- (ys,zs) = removeDupsEq (filter (/= x) xs)
-removeDupsEq (x:xs) | otherwise = (x:ys, zs)
- where
- (ys,zs) = removeDupsEq xs
-\end{code}
-
-
-\begin{code}
-equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
- -- NB: it's *very* important that if we have the input list [a,b,c],
- -- where a,b,c all have the same unique, then we get back the list
- -- [a,b,c]
- -- not
- -- [c,b,a]
- -- Hence the use of foldr, plus the reversed-args tack_on below
-equivClassesByUniq get_uniq xs
- = eltsUFM (foldr add emptyUFM xs)
- where
- add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
- tack_on old new = new++old
-\end{code}
-
-%************************************************************************
-%* *
\subsection[Utils-sorting]{Sorting}
%* *
%************************************************************************
% -----------------------------------------------------------------------------
-% $Id: PrelBase.lhs,v 1.38 2000/09/26 16:45:34 simonpj Exp $
+% $Id: PrelBase.lhs,v 1.39 2000/10/03 08:43:05 simonpj Exp $
%
% (c) The University of Glasgow, 1992-2000
%
%*********************************************************
%* *
+\subsection{Generics}
+%* *
+%*********************************************************
+
+\begin{code}
+data Unit = Unit
+data a :+: b = Inl a | Inr b
+data a :*: b = a :*: b
+\end{code}
+
+
+%*********************************************************
+%* *
\subsection{Numeric primops}
%* *
%*********************************************************
projects / ghc-hetmet.git / commitdiff