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.lhs52
-rw-r--r--compiler/iface/LoadIface.lhs19
-rw-r--r--compiler/iface/MkIface.lhs27
-rw-r--r--compiler/iface/TcIface.lhs36
5 files changed, 79 insertions, 57 deletions
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index e412d7ef30..170edfe591 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -129,7 +129,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 1283b095fd..853fafc0ed 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -40,8 +40,10 @@ import IfaceType
import PprCore() -- Printing DFunArgs
import Demand
import Class
+import TyCon
+import FieldLabel
import NameSet
-import CoAxiom ( BranchIndex, Role )
+import CoAxiom ( BranchIndex )
import Name
import CostCentre
import Literal
@@ -356,29 +358,29 @@ instance Binary IfaceAxBranch where
return (IfaceAxBranch a1 a2 a3 a4 a5)
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] [FieldLbl OccName] -- Data type decls
+ | IfNewTyCon IfaceConDecl [FieldLbl OccName] -- Newtype decls
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 fs) = putByte bh 2 >> put_ bh cs >> put_ bh fs
+ put_ bh (IfNewTyCon c fs) = putByte bh 3 >> put_ bh c >> 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 -> liftM2 IfDataTyCon (get bh) (get bh)
+ _ -> liftM2 IfNewTyCon (get bh) (get bh)
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls (IfAbstractTyCon {}) = []
-visibleIfConDecls IfDataFamTyCon = []
-visibleIfConDecls (IfDataTyCon cs) = cs
-visibleIfConDecls (IfNewTyCon c) = [c]
+visibleIfConDecls IfDataFamTyCon = []
+visibleIfConDecls (IfDataTyCon cs _) = cs
+visibleIfConDecls (IfNewTyCon c _) = [c]
data IfaceConDecl
= IfCon {
@@ -390,7 +392,7 @@ data IfaceConDecl
ifConEqSpec :: [(OccName,IfaceType)], -- Equality constraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
- ifConFields :: [OccName], -- ...ditto... (field labels)
+ ifConFields :: [OccName], -- Field labels
ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
@@ -969,7 +971,7 @@ ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = []
-- Newtype
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (
- IfCon { ifConOcc = con_occ })})
+ 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)
@@ -977,7 +979,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
@@ -1086,9 +1088,9 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
| otherwise = ptext (sLit "Not promotable")
pp_nd = case condecls of
IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis)
- IfDataFamTyCon -> ptext (sLit "data family")
- IfDataTyCon _ -> ptext (sLit "data")
- IfNewTyCon _ -> ptext (sLit "newtype")
+ IfDataFamTyCon -> ptext (sLit "data family")
+ IfDataTyCon _ _ -> ptext (sLit "data")
+ IfNewTyCon _ _ -> ptext (sLit "newtype")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs,
@@ -1153,9 +1155,9 @@ pprIfaceDeclHead context thing tyvars
pp_condecls :: OccName -> IfaceConDecls -> SDoc
pp_condecls _ (IfAbstractTyCon {}) = empty
-pp_condecls _ IfDataFamTyCon = empty
-pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
-pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
+pp_condecls _ IfDataFamTyCon = empty
+pp_condecls tc (IfNewTyCon c _) = equals <+> pprIfaceConDecl tc c
+pp_condecls tc (IfDataTyCon cs _) = equals <+> sep (punctuate (ptext (sLit " |"))
(map (pprIfaceConDecl tc) cs))
mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType
@@ -1430,9 +1432,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 =
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index d787794326..6ac7dde010 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -772,14 +772,17 @@ When printing export lists, we print like this:
\begin{code}
pprExport :: IfaceExport -> SDoc
-pprExport (Avail n) = ppr n
-pprExport (AvailTC _ []) = empty
-pprExport (AvailTC n (n':ns))
- | n==n' = ppr n <> pp_export ns
- | otherwise = ppr n <> char '|' <> pp_export (n':ns)
- where
- pp_export [] = empty
- pp_export names = braces (hsep (map ppr names))
+pprExport (Avail n) = ppr n
+pprExport (AvailTC _ [] []) = empty
+pprExport (AvailTC n (n':ns) fs)
+ | n==n' = ppr n <> pp_export ns fs
+ | otherwise = ppr n <> char '|' <> pp_export (n':ns) fs
+pprExport (AvailTC n [] fs) = ppr n <> char '|' <> pp_export [] fs
+
+pp_export :: [Name] -> AvailFields -> SDoc
+pp_export [] [] = 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 bb51cdae9d..93386e5c04 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -104,6 +104,7 @@ import UniqFM
import Unique
import Util hiding ( eqListBy )
import FastString
+import FastStringEnv
import Maybes
import ListSetOps
import Binary
@@ -1069,11 +1070,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]
@@ -1572,7 +1576,7 @@ tyConToIfaceDecl env tycon
ifTyVars = toIfaceTvBndrs tyvars,
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext 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),
@@ -1596,10 +1600,10 @@ tyConToIfaceDecl env tycon
to_ifsyn_rhs (BuiltInSynFamTyCon {}) = pprPanic "toIfaceDecl: BuiltInFamTyCon" (ppr tycon)
- 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) (ifaceFields flds)
+ ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (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
@@ -1614,8 +1618,7 @@ tyConToIfaceDecl env tycon
ifConEqSpec = to_eq_spec eq_spec,
ifConCtxt = tidyToIfaceContext env2 theta,
ifConArgTys = map (tidyToIfaceType env2) arg_tys,
- ifConFields = map getOccName
- (dataConFieldLabels data_con),
+ ifConFields = map (nameOccName . flSelector) (dataConFieldLabels data_con),
ifConStricts = map (toIfaceBang env2) (dataConRepBangs data_con) }
where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
@@ -1627,6 +1630,8 @@ tyConToIfaceDecl env tycon
to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty)
| (tv,ty) <- spec]
+ ifaceFields flds = map (fmap nameOccName) $ 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 cc45648ea2..9c1e6701b6 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -69,9 +69,10 @@ import DynFlags
import Util
import FastString
+import Data.List
+import Data.Traversable (traverse)
import Control.Monad
import qualified Data.Map as Map
-import Data.Traversable ( traverse )
\end{code}
This module takes
@@ -632,16 +633,21 @@ tcIfaceDataCons tycon_name tycon _ 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 fs -> do { field_lbls <- mapM tc_field_lbl fs
+ ; data_cons <- mapM (tc_con_decl field_lbls) cons
+ ; return (mkDataTyConRhs data_cons) }
+ IfNewTyCon con fs -> do { field_lbls <- mapM tc_field_lbl fs
+ ; data_con <- (tc_con_decl field_lbls) con
+ ; mkNewTyConRhs tycon_name tycon data_con }
where
- tc_con_decl (IfCon { ifConInfix = is_infix,
- ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
- ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
- ifConArgTys = args, ifConFields = field_lbls,
- ifConStricts = if_stricts})
+ tc_field_lbl :: FieldLbl OccName -> IfL FieldLabel
+ tc_field_lbl = traverse lookupIfaceTop
+
+ tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
+ ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
+ ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
+ ifConArgTys = args, ifConFields = my_lbls,
+ ifConStricts = if_stricts})
= bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
{ traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
@@ -660,7 +666,13 @@ tcIfaceDataCons tycon_name tycon _ 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
@@ -668,7 +680,7 @@ tcIfaceDataCons tycon_name tycon _ if_cons
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
name is_infix
- stricts lbl_names
+ stricts my_field_lbls
univ_tyvars ex_tyvars
eq_spec theta
arg_tys orig_res_ty tycon
View Lorry Controller Status