diff options
Diffstat (limited to 'compiler/iface/TcIface.lhs')
| -rw-r--r-- | compiler/iface/TcIface.lhs | 36 |
1 files changed, 24 insertions, 12 deletions
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 |