Commit 710e2074 authored by simonpj's avatar simonpj

[project @ 2000-10-03 08:43:00 by simonpj]

--------------------------------------
	Adding generics		SLPJ Oct 2000
	--------------------------------------

This big commit adds Hinze/PJ-style generic class definitions, based
on work by Andrei Serjantov.  For example:

  class Bin a where
    toBin   :: a -> [Int]
    fromBin :: [Int] -> (a, [Int])

    toBin {| Unit |}    Unit	  = []
    toBin {| a :+: b |} (Inl x)   = 0 : toBin x
    toBin {| a :+: b |} (Inr y)   = 1 : toBin y
    toBin {| a :*: b |} (x :*: y) = toBin x ++ toBin y


    fromBin {| Unit |}    bs      = (Unit, bs)
    fromBin {| a :+: b |} (0:bs)  = (Inl x, bs')    where (x,bs') = fromBin bs
    fromBin {| a :+: b |} (1:bs)  = (Inr y, bs')    where (y,bs') = fromBin bs
    fromBin {| a :*: b |} bs  	  = (x :*: y, bs'') where (x,bs' ) = fromBin bs
							  (y,bs'') = fromBin bs'

Now we can say simply

  instance Bin a => Bin [a]

and the compiler will derive the appropriate code automatically.

		(About 9k lines of diffs.  Ha!)


Generic related things
~~~~~~~~~~~~~~~~~~~~~~

* basicTypes/BasicTypes: The EP type (embedding-projection pairs)

* types/TyCon:
	An extra field in an algebraic tycon (genInfo)

* types/Class, and hsSyn/HsBinds:
	Each class op (or ClassOpSig) carries information about whether
	it  	a) has no default method
		b) has a polymorphic default method
		c) has a generic default method
	There's a new data type for this: Class.DefMeth

* types/Generics:
	A new module containing good chunk of the generic-related code
	It has a .hi-boot file (alas).

* typecheck/TcInstDcls, typecheck/TcClassDcl:
	Most of the rest of the generics-related code

* hsSyn/HsTypes:
	New infix type form to allow types of the form
		data a :+: b = Inl a | Inr b

* parser/Parser.y, Lex.lhs, rename/ParseIface.y:
	Deal with the new syntax

* prelude/TysPrim, TysWiredIn:
	Need to generate generic stuff for the wired-in TyCons

* rename/RnSource RnBinds:
	A rather gruesome hack to deal with scoping of type variables
	from a generic patterns.  Details commented in the ClassDecl
	case of RnSource.rnDecl.

	Of course, there are many minor renamer consequences of the
	other changes above.

* lib/std/PrelBase.lhs
	Data type declarations for Unit, :+:, :*:


Slightly unrelated housekeeping
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* hsSyn/HsDecls:
	ClassDecls now carry the Names for their implied declarations
	(superclass selectors, tycon, etc) in a list, rather than
	laid out one by one.  This simplifies code between the parser
	and the type checker.

* prelude/PrelNames, TysWiredIn:
	All the RdrNames are now together in PrelNames.

* utils/ListSetOps:
	Add finite mappings based on equality and association lists (Assoc a b)
	Move stuff from List.lhs that is related
parent af099cc1
......@@ -16,7 +16,7 @@ then
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
......@@ -26,7 +26,7 @@ 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
......@@ -45,7 +45,7 @@ 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
......
......@@ -34,8 +34,9 @@ module BasicTypes(
OccInfo(..), seqOccInfo, isFragileOcc, isDeadOcc, isLoopBreaker,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch
OneBranch, oneBranch, notOneBranch,
EP(..)
) where
#include "HsVersions.h"
......@@ -197,6 +198,42 @@ isNonRec Recursive = False
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.
%************************************************************************
%* *
......
......@@ -47,7 +47,7 @@ import CmdLineOpts ( opt_UnboxStrictFields )
import PprType () -- Instances
import Maybes ( maybeToBool )
import Maybe
import Util ( assoc )
import ListSetOps ( assoc )
\end{code}
......
......@@ -9,7 +9,7 @@ module Id (
-- Simple construction
mkId, mkVanillaId, mkSysLocal, mkUserLocal,
mkTemplateLocals, mkWildId, mkTemplateLocal,
mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
-- Taking an Id apart
idName, idType, idUnique, idInfo,
......@@ -29,7 +29,8 @@ module Id (
isIP,
isSpecPragmaId, isRecordSelector,
isPrimOpId, isPrimOpId_maybe,
isDataConId, isDataConId_maybe, isDataConWrapId, isDataConWrapId_maybe,
isDataConId, isDataConId_maybe, isDataConWrapId,
isDataConWrapId_maybe,
isBottomingId,
isExportedId, isUserExportedId,
hasNoBinding,
......@@ -62,24 +63,28 @@ module Id (
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
......@@ -95,9 +100,14 @@ import PrimOp ( PrimOp, primOpIsCheap )
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`,
......@@ -160,6 +170,11 @@ mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
(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}
......@@ -451,3 +466,13 @@ zapLamIdInfo :: Id -> Id
zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
\end{code}
......@@ -40,7 +40,7 @@ import TysWiredIn ( boolTy, charTy, mkListTy )
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,
......@@ -92,7 +92,7 @@ import Maybes
import PrelNames
import Maybe ( isJust )
import Outputable
import Util ( assoc )
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
import Char ( ord )
\end{code}
......@@ -111,8 +111,9 @@ wiredInIds
-- 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
......@@ -618,13 +619,13 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-> 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.
......@@ -653,7 +654,6 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
-- 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}
......
......@@ -13,7 +13,7 @@ module Name (
mkLocalName, mkImportedLocalName, mkSysLocalName, mkCCallName,
mkTopName, mkIPName,
mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
mkWiredInIdName, mkWiredInTyConName,
mkWiredInIdName, mkWiredInTyConName,
mkUnboundName, isUnboundName,
maybeWiredInIdName, maybeWiredInTyConName,
......@@ -28,6 +28,7 @@ module Name (
nameSrcLoc, isLocallyDefinedName, isDllName,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
isTyVarName,
-- Environment
NameEnv, mkNameEnv,
......@@ -121,8 +122,8 @@ mkGlobalName uniq mod occ prov = Name { n_uniq = uniq, n_sort = Global mod,
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
......@@ -166,13 +167,10 @@ mkWiredInIdName :: Unique -> Module -> OccName -> Id -> Name
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 }
---------------------------------------------------------------------
......@@ -493,6 +491,9 @@ isLocalName _ = False
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).
......@@ -567,6 +568,7 @@ elemNameEnv :: Name -> NameEnv a -> Bool
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
......@@ -578,6 +580,7 @@ plusNameEnv_C = plusUFM_C
extendNameEnvList= addListToUFM
delFromNameEnv = delFromUFM
elemNameEnv = elemUFM
mapNameEnv = mapUFM
unitNameEnv = unitUFM
lookupNameEnv = lookupUFM
......
......@@ -9,7 +9,7 @@ module NameSet (
NameSet,
emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet,
delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet
delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet
) where
#include "HsVersions.h"
......@@ -41,6 +41,7 @@ isEmptyNameSet :: NameSet -> Bool
delFromNameSet :: NameSet -> Name -> NameSet
delListFromNameSet :: NameSet -> [Name] -> NameSet
foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b
filterNameSet :: (Name -> Bool) -> NameSet -> NameSet
isEmptyNameSet = isEmptyUniqSet
emptyNameSet = emptyUniqSet
......@@ -55,6 +56,7 @@ elemNameSet = elementOfUniqSet
nameSetToList = uniqSetToList
delFromNameSet = delOneFromUniqSet
foldNameSet = foldUniqSet
filterNameSet = filterUniqSet
delListFromNameSet set ns = foldl delFromNameSet set ns
\end{code}
......
......@@ -18,6 +18,7 @@ module OccName (
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
mkGenOcc1, mkGenOcc2,
isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
......@@ -308,7 +309,8 @@ mkDictOcc = mk_simple_deriv varName "$d"
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)
......
......@@ -41,7 +41,7 @@ module Unique (
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
mkPreludeTyConUnique, mkPreludeClassUnique,
getBuiltinUniques, mkBuiltinUnique,
getNumBuiltinUniques, getBuiltinUniques, mkBuiltinUnique,
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
) where
......@@ -286,7 +286,7 @@ Allocation of unique supply characters:
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
......@@ -329,5 +329,10 @@ mkPseudoUnique3 i = mkUnique 'E' i -- used in NCG spiller to create spill Virtua
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 $
%
%********************************************************
%* *
......@@ -47,7 +47,8 @@ import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
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 $
%
%********************************************************
%* *
......@@ -48,13 +48,14 @@ import ClosureInfo ( nodeMustPointToIt,
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 )
......
......@@ -18,7 +18,7 @@ import DsUtils
import Id ( Id )
import CoreSyn
import Type ( mkTyVarTys )
import Util ( equivClassesByUniq )
import ListSetOps ( equivClassesByUniq )
import Unique ( Uniquable(..) )
\end{code}
......
......@@ -25,6 +25,7 @@ import BasicTypes ( RecFlag(..), Fixity )
import Outputable
import SrcLoc ( SrcLoc )
import Var ( TyVar )
import Class ( DefMeth (..) )
\end{code}
%************************************************************************
......@@ -236,11 +237,9 @@ data Sig name
(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
......@@ -338,8 +337,15 @@ ppr_sig (ClassOpSig var dm ty _)
= 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],
......
......@@ -15,7 +15,10 @@ module HsDecls (
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"
......@@ -91,12 +94,13 @@ hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
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}
......@@ -186,10 +190,12 @@ data TyClDecl name pat
-- 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...
......@@ -199,15 +205,29 @@ data TyClDecl name pat
[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 ->
......@@ -220,8 +240,8 @@ instance Ord name => Eq (TyClDecl name pat) where
= 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 &&
......@@ -242,7 +262,7 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
-- 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}
......@@ -251,9 +271,9 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
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
......@@ -261,10 +281,10 @@ 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}
......@@ -276,7 +296,7 @@ instance (Outputable name, Outputable pat)
= 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)
......@@ -286,7 +306,7 @@ instance (Outputable name, Outputable pat)
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
......
......@@ -153,6 +153,7 @@ data HsExpr id pat
| 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.
......@@ -165,6 +166,8 @@ The renamer translates them into the Right Thing.
(HsExpr id pat)
| ELazyPat (HsExpr id pat) -- ~ pattern
| HsType (HsType id) -- Explicit type argument; e.g f {| Int |} x y
\end{code}