summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/BuildTyCl.lhs2
-rw-r--r--compiler/iface/IfaceSyn.lhs47
-rw-r--r--compiler/iface/LoadIface.lhs16
-rw-r--r--compiler/iface/MkIface.lhs31
-rw-r--r--compiler/iface/TcIface.lhs30
5 files changed, 77 insertions, 49 deletions
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 2a66de28ac..f1a363003a 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -123,7 +123,7 @@ mkNewTyConRhs tycon_name tycon con
buildDataCon :: FamInstEnvs
-> Name -> Bool
-> [HsBang]
- -> [Name] -- Field labels
+ -> [FieldLabel] -- Field labels
-> [TyVar] -> [TyVar] -- Univ and ext
-> [(TyVar,Type)] -- Equality spec
-> ThetaType -- Does not include the "stupid theta"
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index e45fac22ce..7ea261e10f 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -38,8 +38,9 @@ import IfaceType
import PprCore() -- Printing DFunArgs
import Demand
import Class
+import FieldLabel
import NameSet
-import CoAxiom ( BranchIndex, Role )
+import CoAxiom ( BranchIndex )
import Name
import CostCentre
import Literal
@@ -176,10 +177,16 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
-- See Note [Storing compatibility] in CoAxiom
data IfaceConDecls
- = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon
- | IfDataFamTyCon -- Data family
- | IfDataTyCon [IfaceConDecl] -- Data type decls
- | IfNewTyCon IfaceConDecl -- Newtype decls
+ = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon
+ | IfDataFamTyCon -- Data family
+ | IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls
+ | IfNewTyCon IfaceConDecl Bool [FieldLabelString] -- Newtype decls
+
+-- For IfDataTyCon and IfNewTyCon we store:
+-- * the data constructor(s);
+-- * a boolean indicating whether OverloadedRecordFields was enabled
+-- at the definition site; and
+-- * a list of field labels.
data IfaceConDecl
= IfCon {
@@ -386,8 +393,8 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls (IfAbstractTyCon {}) = []
visibleIfConDecls IfDataFamTyCon = []
-visibleIfConDecls (IfDataTyCon cs) = cs
-visibleIfConDecls (IfNewTyCon c) = [c]
+visibleIfConDecls (IfDataTyCon cs _ _) = cs
+visibleIfConDecls (IfNewTyCon c _ _) = [c]
\end{code}
\begin{code}
@@ -406,8 +413,7 @@ ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = []
-- Newtype
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
- ifCons = IfNewTyCon (
- IfCon { ifConOcc = con_occ })})
+ ifCons = IfNewTyCon (IfCon { ifConOcc = con_occ }) _ _})
= -- implicit newtype coercion
(mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit
-- data constructor and worker (newtypes don't have a wrapper)
@@ -415,7 +421,7 @@ ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
- ifCons = IfDataTyCon cons })
+ ifCons = IfDataTyCon cons _ _ })
= -- for each data constructor in order,
-- data constructor, worker, and (possibly) wrapper
concatMap dc_occs cons
@@ -704,15 +710,14 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
pp_nd = case condecls of
IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d))
IfDataFamTyCon -> ptext (sLit "data family")
- IfDataTyCon _ -> ptext (sLit "data")
- IfNewTyCon _ -> ptext (sLit "newtype")
+ IfDataTyCon{} -> ptext (sLit "data")
+ IfNewTyCon{} -> ptext (sLit "newtype")
pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom]
pp_prom | is_prom = ptext (sLit "Promotable")
| otherwise = Outputable.empty
-
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
, ifCtxt = context, ifName = clas
, ifTyVars = tyvars, ifRoles = roles
@@ -1183,9 +1188,9 @@ freeNamesIfClsSig :: IfaceClassOp -> NameSet
freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
freeNamesIfConDecls :: IfaceConDecls -> NameSet
-freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
-freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c
-freeNamesIfConDecls _ = emptyNameSet
+freeNamesIfConDecls (IfDataTyCon c _ _) = fnList freeNamesIfConDecl c
+freeNamesIfConDecls (IfNewTyCon c _ _) = freeNamesIfConDecl c
+freeNamesIfConDecls _ = emptyNameSet
freeNamesIfConDecl :: IfaceConDecl -> NameSet
freeNamesIfConDecl c
@@ -1559,16 +1564,16 @@ instance Binary IfaceAxBranch where
instance Binary IfaceConDecls where
put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
- put_ bh IfDataFamTyCon = putByte bh 1
- put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs
- put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c
+ put_ bh IfDataFamTyCon = putByte bh 1
+ put_ bh (IfDataTyCon cs b fs) = putByte bh 2 >> put_ bh cs >> put_ bh b >> put_ bh fs
+ put_ bh (IfNewTyCon c b fs) = putByte bh 3 >> put_ bh c >> put_ bh b >> put_ bh fs
get bh = do
h <- getByte bh
case h of
0 -> liftM IfAbstractTyCon $ get bh
1 -> return IfDataFamTyCon
- 2 -> liftM IfDataTyCon $ get bh
- _ -> liftM IfNewTyCon $ get bh
+ 2 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
+ _ -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
instance Binary IfaceConDecl where
put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index fa6f603d8e..052009b2df 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -774,14 +774,14 @@ When printing export lists, we print like this:
\begin{code}
pprExport :: IfaceExport -> SDoc
-pprExport (Avail n) = ppr n
-pprExport (AvailTC _ []) = Outputable.empty
-pprExport (AvailTC n (n':ns))
- | n==n' = ppr n <> pp_export ns
- | otherwise = ppr n <> char '|' <> pp_export (n':ns)
- where
- pp_export [] = Outputable.empty
- pp_export names = braces (hsep (map ppr names))
+pprExport (Avail n) = ppr n
+pprExport (AvailTC _ [] []) = Outputable.empty
+pprExport (AvailTC n (n':ns) fs)
+ | n==n' = ppr n <> pp_export ns fs
+ | otherwise = ppr n <> char '|' <> pp_export (n':ns) fs
+ where
+ pp_export [] [] = Outputable.empty
+ pp_export names fs = braces (hsep (map ppr names ++ map pprAvailField fs))
pprUsage :: Usage -> SDoc
pprUsage usage@UsagePackageModule{}
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index ec41f0ddd2..cb5c662e98 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -107,6 +107,7 @@ import UniqFM
import Unique
import Util hiding ( eqListBy )
import FastString
+import FastStringEnv
import Maybes
import ListSetOps
import Binary
@@ -1100,11 +1101,14 @@ mkIfaceExports exports
where
sort_subs :: AvailInfo -> AvailInfo
sort_subs (Avail n) = Avail n
- sort_subs (AvailTC n []) = AvailTC n []
- sort_subs (AvailTC n (m:ms))
- | n==m = AvailTC n (m:sortBy stableNameCmp ms)
- | otherwise = AvailTC n (sortBy stableNameCmp (m:ms))
+ sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
+ sort_subs (AvailTC n (m:ms) fs)
+ | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
+ | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
-- Maintain the AvailTC Invariant
+
+ sort_flds :: AvailFields -> AvailFields
+ sort_flds = sortBy (stableNameCmp `on` fst)
\end{code}
Note [Orignal module]
@@ -1612,7 +1616,7 @@ tyConToIfaceDecl env tycon
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
- ifCons = ifaceConDecls (algTyConRhs tycon),
+ ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifPromotable = isJust (promotableTyCon_maybe tycon),
@@ -1630,7 +1634,7 @@ tyConToIfaceDecl env tycon
ifTyVars = funAndPrimTyVars,
ifRoles = tyConRoles tycon,
ifCtxt = [],
- ifCons = IfDataTyCon [],
+ ifCons = IfDataTyCon [] False [],
ifRec = boolToRecFlag False,
ifGadtSyntax = False,
ifPromotable = False,
@@ -1662,10 +1666,10 @@ tyConToIfaceDecl env tycon
= IfaceBuiltInSynFamTyCon
- ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
- ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon
- ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct
+ ifaceConDecls (NewTyCon { data_con = con }) flds = IfNewTyCon (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds)
+ ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
+ ifaceConDecls (DataFamilyTyCon {}) _ = IfDataFamTyCon
+ ifaceConDecls (AbstractTyCon distinct) _ = IfAbstractTyCon distinct
-- 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
@@ -1679,7 +1683,7 @@ tyConToIfaceDecl env tycon
ifConEqSpec = map to_eq_spec eq_spec,
ifConCtxt = tidyToIfaceContext con_env2 theta,
ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
- ifConFields = map getOccName
+ ifConFields = map (nameOccName . flSelector)
(dataConFieldLabels data_con),
ifConStricts = map (toIfaceBang con_env2) (dataConRepBangs data_con) }
where
@@ -1698,6 +1702,11 @@ tyConToIfaceDecl env tycon
(con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
+ ifaceOverloaded flds = case fsEnvElts flds of
+ fl:_ -> flIsOverloaded fl
+ [] -> False
+ ifaceFields flds = map flLabel $ fsEnvElts flds
+
toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
toIfaceBang _ HsNoBang = IfNoBang
toIfaceBang _ (HsUnpack Nothing) = IfUnpack
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index bb5186931d..b4f27d1723 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -46,6 +46,7 @@ import TyCon
import CoAxiom
import ConLike
import DataCon
+import FieldLabel
import PrelNames
import TysWiredIn
import TysPrim ( superKindTyConName )
@@ -70,6 +71,7 @@ import DynFlags
import Util
import FastString
+import Data.List
import Control.Monad
import qualified Data.Map as Map
#if __GLASGOW_HASKELL__ < 709
@@ -640,15 +642,21 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
= case if_cons of
IfAbstractTyCon dis -> return (AbstractTyCon dis)
IfDataFamTyCon -> return DataFamilyTyCon
- IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
- ; return (mkDataTyConRhs data_cons) }
- IfNewTyCon con -> do { data_con <- tc_con_decl con
- ; mkNewTyConRhs tycon_name tycon data_con }
+ IfDataTyCon cons is_overloaded fs -> do { field_lbls <- mapM (tc_field_lbl is_overloaded) fs
+ ; data_cons <- mapM (tc_con_decl field_lbls) cons
+ ; return (mkDataTyConRhs data_cons) }
+ IfNewTyCon con is_overloaded fs -> do { field_lbls <- mapM (tc_field_lbl is_overloaded) fs
+ ; data_con <- (tc_con_decl field_lbls) con
+ ; mkNewTyConRhs tycon_name tycon data_con }
where
- tc_con_decl (IfCon { ifConInfix = is_infix,
+ tc_field_lbl :: Bool -> FieldLabelString -> IfL FieldLabel
+ tc_field_lbl is_overloaded lbl = traverse lookupIfaceTop
+ $ mkFieldLabelOccs lbl (nameOccName tycon_name) is_overloaded
+
+ tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
ifConExTvs = ex_tvs,
ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
- ifConArgTys = args, ifConFields = field_lbls,
+ ifConArgTys = args, ifConFields = my_lbls,
ifConStricts = if_stricts})
= -- Universally-quantified tyvars are shared with
-- parent TyCon, and are alrady in scope
@@ -669,7 +677,13 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
-- The IfBang field can mention
-- the type itself; hence inside forkM
; return (eq_spec, theta, arg_tys, stricts) }
- ; lbl_names <- mapM lookupIfaceTop field_lbls
+
+ -- Look up the field labels for this constructor; note that
+ -- they should be in the same order as my_lbls!
+ ; let my_field_lbls = map find_lbl my_lbls
+ find_lbl x = case find (\ fl -> nameOccName (flSelector fl) == x) field_lbls of
+ Just fl -> fl
+ Nothing -> error $ "find_lbl missing " ++ occNameString x
-- Remember, tycon is the representation tycon
; let orig_res_ty = mkFamilyTyConApp tycon
@@ -677,7 +691,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
name is_infix
- stricts lbl_names
+ stricts my_field_lbls
tc_tyvars ex_tyvars
eq_spec theta
arg_tys orig_res_ty tycon
View Lorry Controller Status