\section[FieldLabel]{The @FieldLabel@ type}
\begin{code}
-module FieldLabel where
+module FieldLabel(
+ FieldLabel, -- Abstract
+
+ mkFieldLabel,
+ fieldLabelName, fieldLabelTyCon, fieldLabelType, fieldLabelTag,
+
+ FieldLabelTag,
+ firstFieldLabelTag, allFieldLabelTags
+ ) where
#include "HsVersions.h"
import {-# SOURCE #-} TypeRep( Type ) -- FieldLabel is compiled very early
+import {-# SOURCE #-} TyCon( TyCon ) -- FieldLabel is compiled very early
import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique )
import Outputable
\begin{code}
data FieldLabel
= FieldLabel Name -- Also used as the Name of the field selector Id
+
+ TyCon -- Parent type constructor
+
Type -- Type of the field; may have free type variables that
-- are the tyvars of its parent *data* constructor, and
-- those will be the same as the tyvars of its parent *type* constructor
allFieldLabelTags :: [FieldLabelTag]
allFieldLabelTags = [firstFieldLabelTag..]
-fieldLabelName (FieldLabel n _ _) = n
-fieldLabelType (FieldLabel _ ty _) = ty
-fieldLabelTag (FieldLabel _ _ tag) = tag
+fieldLabelName (FieldLabel n _ _ _) = n
+fieldLabelTyCon (FieldLabel _ tc _ _) = tc
+fieldLabelType (FieldLabel _ _ ty _) = ty
+fieldLabelTag (FieldLabel _ _ _ tag) = tag
instance Eq FieldLabel where
- (FieldLabel n1 _ _) == (FieldLabel n2 _ _) = n1 == n2
+ fl1 == fl2 = fieldLabelName fl1 == fieldLabelName fl2
instance Outputable FieldLabel where
- ppr (FieldLabel n _ _) = ppr n
+ ppr fl = ppr (fieldLabelName fl)
instance NamedThing FieldLabel where
- getName (FieldLabel n _ _) = n
+ getName = fieldLabelName
instance Uniquable FieldLabel where
- getUnique (FieldLabel n _ _) = nameUnique n
+ getUnique fl = nameUnique (fieldLabelName fl)
\end{code}
where
ty = exprType rhs
sel_id = mkId name ty info
- field_lbl = mkFieldLabel name ty tag
+ field_lbl = mkFieldLabel name tycon ty tag
tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
info = mkIdInfo (RecordSelId field_lbl)
mapDs (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds ->
returnDs (sel_binds ++ rest)
- -- Common case: one exported variable
- -- All non-recursive bindings come through this way
+ -- Common special case: no type or dictionary abstraction
+dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
+ = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
+ let
+ exports' = [(global, Var local) | (_, global, local) <- exports]
+ in
+ returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
+
+ -- Another common case: one exported variable
+ -- Non-recursive bindings come through this way
dsMonoBinds auto_scc
(AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) rest
= ASSERT( all (`elem` tyvars) all_tyvars )
in
returnDs (global' : rest)
- -- Another common special case: no type or dictionary abstraction
-dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
- = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
- let
- exports' = [(global, Var local) | (_, global, local) <- exports]
- in
- returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
-
dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
= dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
lie_avail1 `plusLIE` lie_avail2)
tc_mb_pats (FunMonoBind name inf matches locn)
- = newTyVarTy boxedTypeKind `thenNF_Tc` \ bndr_ty ->
+ = new_lhs_ty `thenNF_Tc` \ bndr_ty ->
tc_pat_bndr name bndr_ty `thenTc` \ bndr_id ->
let
complete_it xve = tcAddSrcLoc locn $
tc_mb_pats bind@(PatMonoBind pat grhss locn)
= tcAddSrcLoc locn $
-
- -- Figure out the appropriate kind for the pattern,
- -- and generate a suitable type variable
- (case is_rec of
- Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types
- NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types
- ) `thenNF_Tc` \ pat_ty ->
+ new_lhs_ty `thenNF_Tc` \ pat_ty ->
-- Now typecheck the pattern
-- We don't support binding fresh type variables in the
returnTc (PatMonoBind pat' grhss' locn, lie)
in
returnTc (complete_it, lie_req, tvs, ids, lie_avail)
+
+ -- Figure out the appropriate kind for the pattern,
+ -- and generate a suitable type variable
+ new_lhs_ty = case is_rec of
+ Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types
+ NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types
\end{code}
%************************************************************************
newTyVarTy, newTyVarTy_OpenKind, zonkTcType )
import Class ( Class )
-import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType
- )
-import Id ( idType, recordSelectorFieldLabel,
- isRecordSelector,
+import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
+import Id ( idType, recordSelectorFieldLabel, isRecordSelector,
Id, mkVanillaId
)
import DataCon ( dataConFieldLabels, dataConSig,
boxedTypeKind, mkArrowKind,
tidyOpenType
)
-import Subst ( mkTopTyVarSubst, substClasses )
+import TyCon ( tyConTyVars )
+import Subst ( mkTopTyVarSubst, substClasses, substTy )
import UsageSPUtils ( unannotTy )
import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet )
import TyCon ( tyConDataCons )
Game plan for record bindings
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For each binding
- field = value
-1. look up "field", to find its selector Id, which must have type
- forall a1..an. T a1 .. an -> tau
- where tau is the type of the field.
+1. Find the TyCon for the bindings, from the first field label.
+
+2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
-2. Instantiate this type
+For each binding field = value
-3. Unify the (T a1 .. an) part with the "expected result type", which
- is passed in. This checks that all the field labels come from the
- same type.
+3. Instantiate the field type (from the field label) using the type
+ envt from step 2.
-4. Type check the value using tcArg, passing tau as the expected
- argument type.
+4 Type check the value using tcArg, passing the field type as
+ the expected argument type.
This extends OK when the field types are universally quantified.
-Actually, to save excessive creation of fresh type variables,
-we
\begin{code}
tcRecordBinds
-> TcM s (TcRecordBinds, LIE)
tcRecordBinds expected_record_ty rbinds
- = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
+ = tcLookupValue first_field_lbl_name `thenNF_Tc` \ first_sel_id ->
+ let
+ tycon = fieldLabelTyCon (recordSelectorFieldLabel first_sel_id)
+ in
+ tcInstTyVars (tyConTyVars tycon) `thenTc` \ (_, arg_tys, tenv) ->
+ unifyTauTy expected_record_ty
+ (mkTyConApp tycon arg_tys) `thenTc_`
+ mapAndUnzipTc (do_bind tycon tenv) rbinds `thenTc` \ (rbinds', lies) ->
returnTc (rbinds', plusLIEs lies)
where
- do_bind (field_label, rhs, pun_flag)
- = tcLookupValue field_label `thenNF_Tc` \ sel_id ->
+ (first_field_lbl_name, _, _) = head rbinds
+
+ do_bind tycon tenv (field_lbl_name, rhs, pun_flag)
+ = tcLookupValue field_lbl_name `thenNF_Tc` \ sel_id ->
+ let
+ field_lbl = recordSelectorFieldLabel sel_id
+ field_ty = substTy tenv (fieldLabelType field_lbl)
+ in
ASSERT( isRecordSelector sel_id )
-- This lookup and assertion will surely succeed, because
-- we check that the fields are indeed record selectors
-- before calling tcRecordBinds
+ ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
+ -- The caller of tcRecordBinds has already checked
+ -- that all the fields come from the same type
- tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
+ tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
- -- Record selectors all have type
- -- forall a1..an. T a1 .. an -> tau
- ASSERT( maybeToBool (splitFunTy_maybe tau) )
- let
- -- Selector must have type RecordType -> FieldType
- Just (record_ty, field_ty) = splitFunTy_maybe tau
- in
- unifyTauTy expected_record_ty record_ty `thenTc_`
- tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
returnTc ((sel_id, rhs', pun_flag), lie)
badFields rbinds data_con
field_label =
case mb_f of
Nothing -> []
- Just f -> [mkFieldLabel (getName f) arg_ty (head allFieldLabelTags)]
+ Just f -> [mkFieldLabel (getName f) tycon arg_ty (head allFieldLabelTags)]
in
mk_data_con [notMarkedStrict] [arg_ty] field_label
arg_stricts = [strict | (_, _, strict) <- field_label_infos]
arg_tys = [ty | (_, ty, _) <- field_label_infos]
- field_labels = [ mkFieldLabel (getName name) ty tag
+ field_labels = [ mkFieldLabel (getName name) tycon ty tag
| ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
in
mk_data_con arg_stricts arg_tys field_labels
projects / ghc-hetmet.git / commitdiff