diff options
Diffstat (limited to 'compiler/iface/IfaceSyn.lhs')
| -rw-r--r-- | compiler/iface/IfaceSyn.lhs | 998 |
1 files changed, 998 insertions, 0 deletions
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs new file mode 100644 index 0000000000..99501a5b68 --- /dev/null +++ b/compiler/iface/IfaceSyn.lhs @@ -0,0 +1,998 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +%************************************************************************ +%* * +\section[HsCore]{Core-syntax unfoldings in Haskell interface files} +%* * +%************************************************************************ + +We could either use this, or parameterise @GenCoreExpr@ on @Types@ and +@TyVars@ as well. Currently trying the former... MEGA SIGH. + +\begin{code} +module IfaceSyn ( + module IfaceType, -- Re-export all this + + IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), + IfaceExpr(..), IfaceAlt, IfaceNote(..), + IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), + IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), + + -- Misc + visibleIfConDecls, + + -- Converting things to IfaceSyn + tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule, + + -- Equality + IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy, + eqIfDecl, eqIfInst, eqIfRule, + + -- Pretty printing + pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead + ) where + +#include "HsVersions.h" + +import CoreSyn +import IfaceType + +import FunDeps ( pprFundeps ) +import NewDemand ( StrictSig, pprIfaceStrictSig ) +import TcType ( deNoteType ) +import Type ( TyThing(..), splitForAllTys, funResultTy ) +import InstEnv ( Instance(..), OverlapFlag ) +import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) +import NewDemand ( isTopSig ) +import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), + arityInfo, cafInfo, newStrictnessInfo, + workerInfo, unfoldingInfo, inlinePragInfo ) +import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon, + isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, + isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, + tyConHasGenerics, tyConArgVrcs, synTyConRhs, + tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) +import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks, + dataConTyCon, dataConIsInfix, isVanillaDataCon ) +import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) +import OccName ( OccName, OccEnv, emptyOccEnv, + lookupOccEnv, extendOccEnv, parenSymOcc, + OccSet, unionOccSets, unitOccSet ) +import Name ( Name, NamedThing(..), nameOccName, isExternalName ) +import CostCentre ( CostCentre, pprCostCentreCore ) +import Literal ( Literal ) +import ForeignCall ( ForeignCall ) +import TysPrim ( alphaTyVars ) +import BasicTypes ( Arity, Activation(..), StrictnessMark, + RecFlag(..), boolToRecFlag, Boxity(..), + tupleParens ) +import Outputable +import FastString +import Maybes ( catMaybes ) +import Util ( lengthIs ) + +infixl 3 &&& +infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType` +\end{code} + + +%************************************************************************ +%* * + Data type declarations +%* * +%************************************************************************ + +\begin{code} +data IfaceDecl + = IfaceId { ifName :: OccName, + ifType :: IfaceType, + ifIdInfo :: IfaceIdInfo } + + | IfaceData { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifCtxt :: IfaceContext, -- The "stupid theta" + ifCons :: IfaceConDecls, -- Includes new/data info + ifRec :: RecFlag, -- Recursive or not? + ifVrcs :: ArgVrcs, + ifGeneric :: Bool -- True <=> generic converter functions available + } -- We need this for imported data decls, since the + -- imported modules may have been compiled with + -- different flags to the current compilation unit + + | IfaceSyn { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifVrcs :: ArgVrcs, + ifSynRhs :: IfaceType -- synonym expansion + } + + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep OccName], -- Functional dependencies + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? + ifVrcs :: ArgVrcs -- ... and what are its argument variances ... + } + + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET + ifExtName :: Maybe FastString } + +data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType + -- Nothing => no default method + -- Just False => ordinary polymorphic default method + -- Just True => generic default method + +data IfaceConDecls + = IfAbstractTyCon -- No info + | IfDataTyCon [IfaceConDecl] -- data type decls + | IfNewTyCon IfaceConDecl -- newtype decls + +visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] +visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] + +data IfaceConDecl + = IfVanillaCon { + ifConOcc :: OccName, -- Constructor name + ifConInfix :: Bool, -- True <=> declared infix + ifConArgTys :: [IfaceType], -- Arg types + ifConStricts :: [StrictnessMark], -- Empty (meaning all lazy), or 1-1 corresp with arg types + ifConFields :: [OccName] } -- ...ditto... (field labels) + | IfGadtCon { + ifConOcc :: OccName, -- Constructor name + ifConTyVars :: [IfaceTvBndr], -- All tyvars + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConResTys :: [IfaceType], -- Result type args + ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types + +data IfaceInst + = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance + ifDFun :: OccName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance + -- There's always a separate IfaceDecl for the DFun, which gives + -- its IdInfo with its full type and version number. + -- The instance declarations taken together have a version number, + -- and we don't want that to wobble gratuitously + -- If this instance decl is *used*, we'll record a usage on the dfun; + -- and if the head does not change it won't be used if it wasn't before + +data IfaceRule + = IfaceRule { + ifRuleName :: RuleName, + ifActivation :: Activation, + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfaceExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleOrph :: Maybe OccName -- Just like IfaceInst + } + +data IfaceIdInfo + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is + +-- Here's a tricky case: +-- * Compile with -O module A, and B which imports A.f +-- * Change function f in A, and recompile without -O +-- * When we read in old A.hi we read in its IdInfo (as a thunk) +-- (In earlier GHCs we used to drop IdInfo immediately on reading, +-- but we do not do that now. Instead it's discarded when the +-- ModIface is read into the various decl pools.) +-- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *) +-- and so gives a new version. + +data IfaceInfoItem + = HsArity Arity + | HsStrictness StrictSig + | HsUnfold Activation IfaceExpr + | HsNoCafRefs + | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo + -- for why we want arity here. + -- NB: we need IfaceExtName (not just OccName) because the worker + -- can simplify to a function in another module. +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. + +-------------------------------- +data IfaceExpr + = IfaceLcl OccName + | IfaceExt IfaceExtName + | IfaceType IfaceType + | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr OccName IfaceType [IfaceAlt] + | IfaceLet IfaceBinding IfaceExpr + | IfaceNote IfaceNote IfaceExpr + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType + +data IfaceNote = IfaceSCC CostCentre + | IfaceCoerce IfaceType + | IfaceInlineCall + | IfaceInlineMe + | IfaceCoreNote String + +type IfaceAlt = (IfaceConAlt, [OccName], IfaceExpr) + -- Note: OccName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files + +data IfaceConAlt = IfaceDefault + | IfaceDataAlt OccName + | IfaceTupleAlt Boxity + | IfaceLitAlt Literal + +data IfaceBinding + = IfaceNonRec IfaceIdBndr IfaceExpr + | IfaceRec [(IfaceIdBndr, IfaceExpr)] +\end{code} + + +%************************************************************************ +%* * +\subsection[HsCore-print]{Printing Core unfoldings} +%* * +%************************************************************************ + +----------------------------- Printing IfaceDecl ------------------------------------ + +\begin{code} +instance Outputable IfaceDecl where + ppr = pprIfaceDecl + +pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info}) + = sep [ ppr var <+> dcolon <+> ppr ty, + nest 2 (ppr info) ] + +pprIfaceDecl (IfaceForeign {ifName = tycon}) + = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] + +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs}) + = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) + 4 (vcat [equals <+> ppr mono_ty, + pprVrcs vrcs]) + +pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, + ifTyVars = tyvars, ifCons = condecls, + ifRec = isrec, ifVrcs = vrcs}) + = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) + 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls]) + where + pp_nd = case condecls of + IfAbstractTyCon -> ptext SLIT("data") + IfDataTyCon _ -> ptext SLIT("data") + IfNewTyCon _ -> ptext SLIT("newtype") + +pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, + ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec}) + = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) + 4 (vcat [pprVrcs vrcs, + pprRec isrec, + sep (map ppr sigs)]) + +pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs +pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec +pprGen True = ptext SLIT("Generics: yes") +pprGen False = ptext SLIT("Generics: no") + +instance Outputable IfaceClassOp where + ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty + +pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc +pprIfaceDeclHead context thing tyvars + = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars] + +pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}") +pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c +pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) + (map (pprIfaceConDecl tc) cs)) + +pprIfaceConDecl tc (IfVanillaCon { + ifConOcc = name, ifConInfix = is_infix, + ifConArgTys = arg_tys, + ifConStricts = strs, ifConFields = fields }) + = sep [ppr name <+> sep (map pprParendIfaceType arg_tys), + if is_infix then ptext SLIT("Infix") else empty, + if null strs then empty + else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)), + if null fields then empty + else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))] + +pprIfaceConDecl tc (IfGadtCon { + ifConOcc = name, + ifConTyVars = tvs, ifConCtxt = ctxt, + ifConArgTys = arg_tys, ifConResTys = res_tys, + ifConStricts = strs }) + = sep [ppr name <+> dcolon <+> pprIfaceForAllPart tvs ctxt (ppr con_tau), + if null strs then empty + else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs))] + where + con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app]) + tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) res_tys + -- Gruesome, but jsut for debug print + +instance Outputable IfaceRule where + ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) + = sep [hsep [doubleQuotes (ftext name), ppr act, + ptext SLIT("forall") <+> pprIfaceBndrs bndrs], + nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args), + ptext SLIT("=") <+> ppr rhs]) + ] + +instance Outputable IfaceInst where + ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, + ifInstCls = cls, ifInstTys = mb_tcs}) + = hang (ptext SLIT("instance") <+> ppr flag + <+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs)) + 2 (equals <+> ppr dfun_id) + where + ppr_mb Nothing = dot + ppr_mb (Just tc) = ppr tc +\end{code} + + +----------------------------- Printing IfaceExpr ------------------------------------ + +\begin{code} +instance Outputable IfaceExpr where + ppr e = pprIfaceExpr noParens e + +pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) + +pprIfaceExpr add_par (IfaceLcl v) = ppr v +pprIfaceExpr add_par (IfaceExt v) = ppr v +pprIfaceExpr add_par (IfaceLit l) = ppr l +pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) +pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty + +pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) +pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as) + +pprIfaceExpr add_par e@(IfaceLam _ _) + = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow, + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] e + collect bs (IfaceLam b e) = collect (b:bs) e + collect bs e = (reverse bs, e) + +-- gaw 2004 +pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)]) +-- gaw 2004 + = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") + <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, + pprIfaceExpr noParens rhs <+> char '}']) + +-- gaw 2004 +pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) +-- gaw 2004 + = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") + <+> ppr bndr <+> char '{', + nest 2 (sep (map ppr_alt alts)) <+> char '}']) + +pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) + = add_par (sep [ptext SLIT("let {"), + nest 2 (ppr_bind (b, rhs)), + ptext SLIT("} in"), + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) + = add_par (sep [ptext SLIT("letrec {"), + nest 2 (sep (map ppr_bind pairs)), + ptext SLIT("} in"), + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body) + +ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, + arrow <+> pprIfaceExpr noParens rhs] + +ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs) +ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) + +ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty, + equals <+> pprIfaceExpr noParens rhs] + +------------------ +pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args) +pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args) + +------------------ +instance Outputable IfaceNote where + ppr (IfaceSCC cc) = pprCostCentreCore cc + ppr (IfaceCoerce ty) = ptext SLIT("__coerce") <+> pprParendIfaceType ty + ppr IfaceInlineCall = ptext SLIT("__inline_call") + ppr IfaceInlineMe = ptext SLIT("__inline_me") + ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s) + +instance Outputable IfaceConAlt where + ppr IfaceDefault = text "DEFAULT" + ppr (IfaceLitAlt l) = ppr l + ppr (IfaceDataAlt d) = ppr d + ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt" + -- IfaceTupleAlt is handled by the case-alternative printer + +------------------ +instance Outputable IfaceIdInfo where + ppr NoInfo = empty + ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}") + +ppr_hs_info (HsUnfold prag unf) = sep [ptext SLIT("Unfolding: ") <> ppr prag, + parens (pprIfaceExpr noParens unf)] +ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity +ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str +ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs") +ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a +\end{code} + + +%************************************************************************ +%* * + Converting things to their Iface equivalents +%* * +%************************************************************************ + + +\begin{code} +tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl +-- Assumption: the thing is already tidied, so that locally-bound names +-- (lambdas, for-alls) already have non-clashing OccNames +-- Reason: Iface stuff uses OccNames, and the conversion here does +-- not do tidying on the way +tyThingToIfaceDecl ext (AnId id) + = IfaceId { ifName = getOccName id, + ifType = toIfaceType ext (idType id), + ifIdInfo = info } + where + info = case toIfaceIdInfo ext (idInfo id) of + [] -> NoInfo + items -> HasInfo items + +tyThingToIfaceDecl ext (AClass clas) + = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, + ifName = getOccName clas, + ifTyVars = toIfaceTvBndrs clas_tyvars, + ifFDs = map toIfaceFD clas_fds, + ifSigs = map toIfaceClassOp op_stuff, + ifRec = boolToRecFlag (isRecursiveTyCon tycon), + ifVrcs = tyConArgVrcs tycon } + where + (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas + tycon = classTyCon clas + + toIfaceClassOp (sel_id, def_meth) + = ASSERT(sel_tyvars == clas_tyvars) + IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty) + where + -- Be careful when splitting the type, because of things + -- like class Foo a where + -- op :: (?x :: String) => a -> a + -- and class Baz a where + -- op :: (Ord a) => a -> a + (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) + op_ty = funResultTy rho_ty + + toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2) + +tyThingToIfaceDecl ext (ATyCon tycon) + | isSynTyCon tycon + = IfaceSyn { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, + ifVrcs = tyConArgVrcs tycon, + ifSynRhs = toIfaceType ext syn_ty } + + | isAlgTyCon tycon + = IfaceData { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, + ifCtxt = toIfaceContext ext (tyConStupidTheta tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), + ifRec = boolToRecFlag (isRecursiveTyCon tycon), + ifVrcs = tyConArgVrcs tycon, + ifGeneric = tyConHasGenerics tycon } + + | isForeignTyCon tycon + = IfaceForeign { ifName = getOccName tycon, + ifExtName = tyConExtName tycon } + + | isPrimTyCon tycon || isFunTyCon tycon + -- Needed in GHCi for ':info Int#', for example + = IfaceData { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), + ifCtxt = [], + ifCons = IfAbstractTyCon, + ifGeneric = False, + ifRec = NonRecursive, + ifVrcs = tyConArgVrcs tycon } + + | otherwise = pprPanic "toIfaceDecl" (ppr tycon) + where + tyvars = tyConTyVars tycon + syn_ty = synTyConRhs tycon + + ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) + ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls AbstractTyCon = IfAbstractTyCon + -- The last case happens when a TyCon has been trimmed during tidying + -- Furthermore, tyThingToIfaceDecl is also used + -- in TcRnDriver for GHCi, when browsing a module, in which case the + -- AbstractTyCon case is perfectly sensible. + + ifaceConDecl data_con + | isVanillaDataCon data_con + = IfVanillaCon {ifConOcc = getOccName (dataConName data_con), + ifConInfix = dataConIsInfix data_con, + ifConArgTys = map (toIfaceType ext) arg_tys, + ifConStricts = strict_marks, + ifConFields = map getOccName field_labels } + | otherwise + = IfGadtCon { ifConOcc = getOccName (dataConName data_con), + ifConTyVars = toIfaceTvBndrs tyvars, + ifConCtxt = toIfaceContext ext theta, + ifConArgTys = map (toIfaceType ext) arg_tys, + ifConResTys = map (toIfaceType ext) res_tys, + ifConStricts = strict_marks } + where + (tyvars, theta, arg_tys, _, res_tys) = dataConSig data_con + field_labels = dataConFieldLabels data_con + strict_marks = dataConStrictMarks data_con + +tyThingToIfaceDecl ext (ADataCon dc) + = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier + + +-------------------------- +instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst +instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, + is_cls = cls, is_tcs = mb_tcs, + is_orph = orph }) + = IfaceInst { ifDFun = getOccName dfun_id, + ifOFlag = oflag, + ifInstCls = ext_lhs cls, + ifInstTys = map do_rough mb_tcs, + ifInstOrph = orph } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) + +-------------------------- +toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] +toIfaceIdInfo ext id_info + = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, + wrkr_hsinfo, unfold_hsinfo] + where + ------------ Arity -------------- + arity_info = arityInfo id_info + arity_hsinfo | arity_info == 0 = Nothing + | otherwise = Just (HsArity arity_info) + + ------------ Caf Info -------------- + caf_info = cafInfo id_info + caf_hsinfo = case caf_info of + NoCafRefs -> Just HsNoCafRefs + _other -> Nothing + + ------------ Strictness -------------- + -- No point in explicitly exporting TopSig + strict_hsinfo = case newStrictnessInfo id_info of + Just sig | not (isTopSig sig) -> Just (HsStrictness sig) + _other -> Nothing + + ------------ Worker -------------- + work_info = workerInfo id_info + has_worker = case work_info of { HasWorker _ _ -> True; other -> False } + wrkr_hsinfo = case work_info of + HasWorker work_id wrap_arity -> + Just (HsWorker (ext (idName work_id)) wrap_arity) + NoWorker -> Nothing + + ------------ Unfolding -------------- + -- The unfolding is redundant if there is a worker + unfold_info = unfoldingInfo id_info + inline_prag = inlinePragInfo id_info + rhs = unfoldingTemplate unfold_info + unfold_hsinfo | neverUnfold unfold_info + || has_worker = Nothing + | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) + +-------------------------- +coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names + -> (Name -> IfaceExtName) -- For the RHS names + -> CoreRule -> IfaceRule +coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn}) + = pprTrace "toHsRule: builtin" (ppr fn) $ + bogusIfaceRule (mkIfaceExtName fn) + +coreRuleToIfaceRule ext_lhs ext_rhs + (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, ru_orph = orph }) + = IfaceRule { ifRuleName = name, ifActivation = act, + ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs, + ifRuleHead = ext_lhs fn, + ifRuleArgs = map do_arg args, + ifRuleRhs = toIfaceExpr ext_rhs rhs, + ifRuleOrph = orph } + where + -- For type args we must remove synonyms from the outermost + -- level. Reason: so that when we read it back in we'll + -- construct the same ru_rough field as we have right now; + -- see tcIfaceRule + do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty)) + do_arg arg = toIfaceExpr ext_lhs arg + +bogusIfaceRule :: IfaceExtName -> IfaceRule +bogusIfaceRule id_name + = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, + ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], + ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } + +--------------------- +toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr +toIfaceExpr ext (Var v) = toIfaceVar ext v +toIfaceExpr ext (Lit l) = IfaceLit l +toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) +toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) +toIfaceExpr ext (App f a) = toIfaceApp ext f [a] +-- gaw 2004 +toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as) +toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) +toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) + +--------------------- +toIfaceNote ext (SCC cc) = IfaceSCC cc +toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) +toIfaceNote ext InlineCall = IfaceInlineCall +toIfaceNote ext InlineMe = IfaceInlineMe +toIfaceNote ext (CoreNote s) = IfaceCoreNote s + +--------------------- +toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r) +toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs] + +--------------------- +toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r) + +--------------------- +toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc) + | otherwise = IfaceDataAlt (getOccName dc) + where + tc = dataConTyCon dc + +toIfaceCon (LitAlt l) = IfaceLitAlt l +toIfaceCon DEFAULT = IfaceDefault + +--------------------- +toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as) +toIfaceApp ext (Var v) as + = case isDataConWorkId_maybe v of + -- We convert the *worker* for tuples into IfaceTuples + Just dc | isTupleTyCon tc && saturated + -> IfaceTuple (tupleTyConBoxity tc) tup_args + where + val_args = dropWhile isTypeArg as + saturated = val_args `lengthIs` idArity v + tup_args = map (toIfaceExpr ext) val_args + tc = dataConTyCon dc + + other -> mkIfaceApps ext (toIfaceVar ext v) as + +toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as + +mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as + +--------------------- +toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr +toIfaceVar ext v + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v)) + -- Foreign calls have special syntax + | isExternalName name = IfaceExt (ext name) + | otherwise = IfaceLcl (nameOccName name) + where + name = idName v +\end{code} + + +%************************************************************************ +%* * + Equality, for interface file version generaion only +%* * +%************************************************************************ + +Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is +EqBut, which gives the set of *locally-defined* things whose version must be equal +for the whole thing to be equal. So the key function is eqIfExt, which compares +IfaceExtNames. + +Of course, equality is also done modulo alpha conversion. + +\begin{code} +data IfaceEq + = Equal -- Definitely exactly the same + | NotEqual -- Definitely different + | EqBut OccSet -- The same provided these local things have not changed + +bool :: Bool -> IfaceEq +bool True = Equal +bool False = NotEqual + +zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information +zapEq (EqBut _) = Equal +zapEq other = other + +(&&&) :: IfaceEq -> IfaceEq -> IfaceEq +Equal &&& x = x +NotEqual &&& x = NotEqual +EqBut occs &&& Equal = EqBut occs +EqBut occs &&& NotEqual = NotEqual +EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2) + +--------------------- +eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq +-- This function is the core of the EqBut stuff +eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2) +eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2) +eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1) +eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1) +eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1) +eqIfExt n1 n2 = NotEqual +\end{code} + + +\begin{code} +--------------------- +eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq +eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2) + = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2) + +eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {}) + = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2) + +eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) + = bool (ifName d1 == ifName d2 && + ifRec d1 == ifRec d2 && + ifVrcs d1 == ifVrcs d2 && + ifGeneric d1 == ifGeneric d2) &&& + eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> + eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& + eq_hsCD env (ifCons d1) (ifCons d2) + ) + -- The type variables of the data type do not scope + -- over the constructors (any more), but they do scope + -- over the stupid context in the IfaceConDecls + +eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) + = bool (ifName d1 == ifName d2) &&& + eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> + eq_ifType env (ifSynRhs d1) (ifSynRhs d2) + ) + +eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {}) + = bool (ifName d1 == ifName d2 && + ifRec d1 == ifRec d2 && + ifVrcs d1 == ifVrcs d2) &&& + eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> + eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& + eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&& + eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2) + ) + +eqIfDecl _ _ = NotEqual -- default case + +-- Helper +eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq +eqWith = eq_ifTvBndrs emptyEqEnv + +----------------------- +eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) +-- All other changes are handled via the version info on the dfun + +eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1) + (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2) + = bool (n1==n2 && a1==a2 && o1 == o2) &&& + f1 `eqIfExt` f2 &&& + eq_ifBndrs emptyEqEnv bs1 bs2 (\env -> + zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&& + -- zapEq: for the LHSs, ignore the EqBut part + eq_ifaceExpr env rhs1 rhs2) + +eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) + = eqListBy (eq_ConDecl env) c1 c2 + +eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2 +eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal +eq_hsCD env d1 d2 = NotEqual + +eq_ConDecl env c1@(IfVanillaCon {}) c2@(IfVanillaCon {}) + = bool (ifConOcc c1 == ifConOcc c2 && + ifConInfix c1 == ifConInfix c2 && + ifConStricts c1 == ifConStricts c2 && + ifConFields c1 == ifConFields c2) &&& + eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2) + +eq_ConDecl env c1@(IfGadtCon {}) c2@(IfGadtCon {}) + = bool (ifConOcc c1 == ifConOcc c2 && + ifConStricts c1 == ifConStricts c2) &&& + eq_ifTvBndrs env (ifConTyVars c1) (ifConTyVars c2) (\ env -> + eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&& + eq_ifTypes env (ifConResTys c1) (ifConResTys c2) &&& + eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)) + +eq_ConDecl env c1 c2 = NotEqual + +eq_hsFD env (ns1,ms1) (ns2,ms2) + = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2 + +eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2) + = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2 +\end{code} + + +\begin{code} +----------------- +eqIfIdInfo NoInfo NoInfo = Equal +eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2 +eqIfIdInfo i1 i2 = NotEqual + +eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2) +eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2) +eq_item (HsUnfold a1 u1) (HsUnfold a2 u2) = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2 +eq_item HsNoCafRefs HsNoCafRefs = Equal +eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2) +eq_item _ _ = NotEqual + +----------------- +eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq +eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2 +eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2 +eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2) +eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2 +eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2 +eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2 +eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2) +eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2 +eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2 + +eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2) + = eq_ifaceExpr env s1 s2 &&& + eq_ifType env ty1 ty2 &&& + eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2) + where + eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2) + = bool (eq_ifaceConAlt c1 c2) &&& + eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2) + +eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2) + = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2) + +eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2) + = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2) + where + (bs1,rs1) = unzip as1 + (bs2,rs2) = unzip as2 + + +eq_ifaceExpr env _ _ = NotEqual + +----------------- +eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool +eq_ifaceConAlt IfaceDefault IfaceDefault = True +eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2 +eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2 +eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2 +eq_ifaceConAlt _ _ = False + +----------------- +eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq +eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2) +eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2) = eq_ifType env t1 t2 +eq_ifaceNote env IfaceInlineCall IfaceInlineCall = Equal +eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal +eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2) +eq_ifaceNote env _ _ = NotEqual +\end{code} + +\begin{code} +--------------------- +eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2 + +------------------- +eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2 +eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2 +eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2 +eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2 +eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2) +eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2 +eq_ifType env _ _ = NotEqual + +------------------- +eq_ifTypes env = eqListBy (eq_ifType env) + +------------------- +eq_ifContext env a b = eqListBy (eq_ifPredType env) a b + +------------------- +eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2 +eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2 +eq_ifPredType env _ _ = NotEqual + +------------------- +eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2 +eqIfTc IfaceIntTc IfaceIntTc = Equal +eqIfTc IfaceCharTc IfaceCharTc = Equal +eqIfTc IfaceBoolTc IfaceBoolTc = Equal +eqIfTc IfaceListTc IfaceListTc = Equal +eqIfTc IfacePArrTc IfacePArrTc = Equal +eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2) +eqIfTc _ _ = NotEqual +\end{code} + +----------------------------------------------------------- + Support code for equality checking +----------------------------------------------------------- + +\begin{code} +------------------------------------ +type EqEnv = OccEnv OccName -- Tracks the mapping from L-variables to R-variables + +eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq +eqIfOcc env n1 n2 = case lookupOccEnv env n1 of + Just n1 -> bool (n1 == n2) + Nothing -> bool (n1 == n2) + +extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv +extendEqEnv env n1 n2 | n1 == n2 = env + | otherwise = extendOccEnv env n1 n2 + +emptyEqEnv :: EqEnv +emptyEqEnv = emptyOccEnv + +------------------------------------ +type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq + +eq_ifNakedBndr :: ExtEnv OccName +eq_ifBndr :: ExtEnv IfaceBndr +eq_ifTvBndr :: ExtEnv IfaceTvBndr +eq_ifIdBndr :: ExtEnv IfaceIdBndr + +eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2) + +eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k +eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k +eq_ifBndr _ _ _ _ = NotEqual + +eq_ifTvBndr env (v1, k1) (v2, k2) k = bool (k1 == k2) &&& k (extendEqEnv env v1 v2) +eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2) + +eq_ifBndrs :: ExtEnv [IfaceBndr] +eq_ifIdBndrs :: ExtEnv [IfaceIdBndr] +eq_ifTvBndrs :: ExtEnv [IfaceTvBndr] +eq_ifNakedBndrs :: ExtEnv [OccName] +eq_ifBndrs = eq_bndrs_with eq_ifBndr +eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr +eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr +eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr + +eq_bndrs_with eq env [] [] k = k env +eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k) +eq_bndrs_with eq env _ _ _ = NotEqual +\end{code} + +\begin{code} +eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq +eqListBy eq [] [] = Equal +eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys +eqListBy eq xs ys = NotEqual + +eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq +eqMaybeBy eq Nothing Nothing = Equal +eqMaybeBy eq (Just x) (Just y) = eq x y +eqMaybeBy eq x y = NotEqual +\end{code} |