summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/BuildTyCl.hs14
-rw-r--r--compiler/iface/IfaceSyn.hs36
-rw-r--r--compiler/iface/IfaceType.hs13
-rw-r--r--compiler/iface/MkIface.hs9
-rw-r--r--compiler/iface/TcIface.hs18
5 files changed, 61 insertions, 29 deletions
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 6085b0cc3c..0b8680d164 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -230,7 +230,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
-- ------------------------------------------------------
-type TcMethInfo = (Name, DefMethSpec, Type)
+type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
-- A temporary intermediate, to communicate between
-- tcClassSigs and buildClass.
@@ -279,7 +279,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
-- class C a => D a
-- we don't get a newtype with no arguments!
args = sc_sel_names ++ op_names
- op_tys = [ty | (_,_,ty) <- sig_stuff]
+ op_tys = [ty | (_,ty,_) <- sig_stuff]
op_names = [op | (op,_,_) <- sig_stuff]
arg_tys = sc_theta ++ op_tys
rec_tycon = classTyCon rec_clas
@@ -327,13 +327,11 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
- mk_op_item rec_clas (op_name, dm_spec, _)
+ mk_op_item rec_clas (op_name, _, dm_spec)
= do { dm_info <- case dm_spec of
- NoDM -> return NoDefMeth
- GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
- ; return (GenDefMeth dm_name) }
- VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
- ; return (DefMeth dm_name) }
+ Nothing -> return Nothing
+ Just spec -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
+ ; return (Just (dm_name, spec)) }
; return (mkDictSelId op_name rec_clas, dm_info) }
{-
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 41d6779785..463078ce67 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -173,10 +173,13 @@ data IfaceFamTyConFlav
| IfaceAbstractClosedSynFamilyTyCon
| IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
-data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType
- -- Nothing => no default method
- -- Just False => ordinary polymorphic default method
- -- Just True => generic default method
+data IfaceClassOp
+ = IfaceClassOp IfaceTopBndr
+ IfaceType -- Class op type
+ (Maybe (DefMethSpec IfaceType)) -- Default method
+ -- The types of both the class op itself,
+ -- and the default method, are *not* quantifed
+ -- over the class variables
data IfaceAT = IfaceAT -- See Class.ClassATItem
IfaceDecl -- The associated type declaration
@@ -814,9 +817,14 @@ instance Outputable IfaceClassOp where
ppr = pprIfaceClassOp showAll
pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc
-pprIfaceClassOp ss (IfaceClassOp n dm ty) = hang opHdr 2 (pprIfaceSigmaType ty)
- where opHdr = pprPrefixIfDeclBndr ss n
- <+> ppShowIface ss (ppr dm) <+> dcolon
+pprIfaceClassOp ss (IfaceClassOp n ty dm)
+ = pp_sig n ty $$ generic_dm
+ where
+ generic_dm | Just (GenericDM dm_ty) <- dm
+ = ptext (sLit "default") <+> pp_sig n dm_ty
+ | otherwise
+ = empty
+ pp_sig n ty = pprPrefixIfDeclBndr ss n <+> dcolon <+> pprIfaceSigmaType ty
instance Outputable IfaceAT where
ppr = pprIfaceAT showAll
@@ -1182,7 +1190,11 @@ freeNamesIfAT (IfaceAT decl mb_def)
Just rhs -> freeNamesIfType rhs
freeNamesIfClsSig :: IfaceClassOp -> NameSet
-freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
+freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm
+
+freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet
+freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty
+freeNamesDM _ = emptyNameSet
freeNamesIfConDecls :: IfaceConDecls -> NameSet
freeNamesIfConDecls (IfDataTyCon c _ _) = fnList freeNamesIfConDecl c
@@ -1538,16 +1550,16 @@ instance Binary IfaceFamTyConFlav where
(ppr (fromIntegral h :: Int)) }
instance Binary IfaceClassOp where
- put_ bh (IfaceClassOp n def ty) = do
+ put_ bh (IfaceClassOp n ty def) = do
put_ bh (occNameFS n)
- put_ bh def
put_ bh ty
+ put_ bh def
get bh = do
n <- get bh
- def <- get bh
ty <- get bh
+ def <- get bh
occ <- return $! mkVarOccFS n
- return (IfaceClassOp occ def ty)
+ return (IfaceClassOp occ ty def)
instance Binary IfaceAT where
put_ bh (IfaceAT dec defs) = do
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 8be97dfe40..7bf949e24f 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -6,7 +6,9 @@
This module defines interface types and binders
-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, FlexibleInstances #-}
+ -- FlexibleInstances for Binary (DefMethSpec IfaceType)
+
module IfaceType (
IfExtName, IfLclName,
@@ -1007,6 +1009,15 @@ instance Binary IfaceCoercion where
return $ IfaceAxiomRuleCo a b c
_ -> panic ("get IfaceCoercion " ++ show tag)
+instance Binary (DefMethSpec IfaceType) where
+ put_ bh VanillaDM = putByte bh 0
+ put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return VanillaDM
+ _ -> do { t <- get bh; return (GenericDM t) }
+
{-
************************************************************************
* *
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 98b8830e01..d955fa5fd9 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1529,8 +1529,9 @@ classToIfaceDecl env clas
toIfaceClassOp (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
- IfaceClassOp (getOccName sel_id) (toDmSpec def_meth)
+ IfaceClassOp (getOccName sel_id)
(tidyToIfaceType env1 op_ty)
+ (fmap toDmSpec def_meth)
where
-- Be careful when splitting the type, because of things
-- like class Foo a where
@@ -1540,9 +1541,9 @@ classToIfaceDecl env clas
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
- toDmSpec NoDefMeth = NoDM
- toDmSpec (GenDefMeth _) = GenericDM
- toDmSpec (DefMeth _) = VanillaDM
+ toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
+ toDmSpec (_, VanillaDM) = VanillaDM
+ toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
toIfaceFD (tvs1, tvs2) = (map (getFS . tidyTyVar env1) tvs1,
map (getFS . tidyTyVar env1) tvs2)
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 45b583cd91..da94136218 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -50,7 +50,7 @@ import PrelNames
import TysWiredIn
import TysPrim ( superKindTyConName )
import BasicTypes ( strongLoopBreaker, Arity, TupleSort(..)
- , Boxity(..), pprRuleName )
+ , Boxity(..), DefMethSpec(..), pprRuleName )
import Literal
import qualified Var
import VarEnv
@@ -419,13 +419,23 @@ tc_iface_decl _parent ignore_prags
-- Here the associated type T is knot-tied with the class, and
-- so we must not pull on T too eagerly. See Trac #5970
- tc_sig (IfaceClassOp occ dm rdr_ty)
+ tc_sig :: IfaceClassOp -> IfL TcMethInfo
+ tc_sig (IfaceClassOp occ rdr_ty dm)
= do { op_name <- lookupIfaceTop occ
- ; op_ty <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty)
+ ; ~(op_ty, dm') <- forkM (mk_op_doc op_name rdr_ty) $
+ do { ty <- tcIfaceType rdr_ty
+ ; dm' <- tc_dm dm
+ ; return (ty, dm') }
-- Must be done lazily for just the same reason as the
-- type of a data con; to avoid sucking in types that
-- it mentions unless it's necessary to do so
- ; return (op_name, dm, op_ty) }
+ ; return (op_name, op_ty, dm') }
+
+ tc_dm :: Maybe (DefMethSpec IfaceType) -> IfL (Maybe (DefMethSpec Type))
+ tc_dm Nothing = return Nothing
+ tc_dm (Just VanillaDM) = return (Just VanillaDM)
+ tc_dm (Just (GenericDM ty)) = do { ty' <- tcIfaceType ty
+ ; return (Just (GenericDM ty')) }
tc_at cls (IfaceAT tc_decl if_def)
= do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
View Lorry Controller Status