Commit 729a6eb1 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-06-02 08:25:10 by simonpj]

-----------------------------------------------
       Record whether data constructors are declared infix
	-----------------------------------------------

This allows us to generate the InfixC form in Template Hasekll.
And for 'deriving' Read and Show, we now read and parse the infix
form iff the constructor was declared infix, rather than just if
it does not have the default fixity (as before).

IfaceSyn changes slightly, so that IfaceConDecl can record their
fixity, so there are trivial changes scattered about, and
you'll need to recompile everything.

In TysWiredIn I took the opportunity to simplify pcDataCon slightly,
by eliminating the unused Theta argument.
parent 5568d10f
......@@ -13,7 +13,7 @@ module DataCon (
dataConRepArgTys, dataConTheta,
dataConFieldLabels, dataConStrictMarks, dataConExStricts,
dataConSourceArity, dataConRepArity,
dataConNumInstArgs,
dataConNumInstArgs, dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness,
isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
......@@ -252,7 +252,11 @@ data DataCon
--
-- An entirely separate wrapper function is built in TcTyDecls
dcIds :: DataConIds
dcIds :: DataConIds,
dcInfix :: Bool -- True <=> declared infix
-- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere
}
data DataConIds
......@@ -342,6 +346,7 @@ instance Show DataCon where
\begin{code}
mkDataCon :: Name
-> Bool -- Declared infix
-> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType
-> [TyVar] -> ThetaType
......@@ -350,7 +355,7 @@ mkDataCon :: Name
-> DataCon
-- Can get the tag from the TyCon
mkDataCon name
mkDataCon name declared_infix
arg_stricts -- Must match orig_arg_tys 1-1
fields
tyvars theta ex_tyvars ex_theta orig_arg_tys tycon
......@@ -365,7 +370,7 @@ mkDataCon name
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
dcIds = ids}
dcIds = ids, dcInfix = declared_infix}
-- Strictness marks for source-args
-- *after unboxing choices*,
......@@ -405,6 +410,9 @@ dataConTyCon = dcTyCon
dataConRepType :: DataCon -> Type
dataConRepType = dcRepType
dataConIsInfix :: DataCon -> Bool
dataConIsInfix = dcInfix
dataConWorkId :: DataCon -> Id
dataConWorkId dc = case dcIds dc of
AlgDC _ wrk_id -> wrk_id
......
......@@ -956,13 +956,14 @@ instance Binary IfaceConDecls where
return (IfNewTyCon aa)
instance Binary IfaceConDecl where
put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6) = do
put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6 a7) = do
put_ bh a1
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh a5
put_ bh a6
put_ bh a7
get bh = do
a1 <- get bh
a2 <- get bh
......@@ -970,7 +971,8 @@ instance Binary IfaceConDecl where
a4 <- get bh
a5 <- get bh
a6 <- get bh
return (IfaceConDecl a1 a2 a3 a4 a5 a6)
a7 <- get bh
return (IfaceConDecl a1 a2 a3 a4 a5 a6 a7)
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
......
......@@ -82,7 +82,7 @@ mkNewTyConRhs con
------------------------------------------------------
buildDataCon :: Name
buildDataCon :: Name -> Bool
-> [StrictnessMark]
-> [Name] -- Field labels
-> [TyVar] -> ThetaType
......@@ -93,30 +93,32 @@ buildDataCon :: Name
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
buildDataCon src_name arg_stricts field_lbl_names
buildDataCon src_name declared_infix arg_stricts field_lbl_names
tyvars ctxt ex_tyvars ex_ctxt
arg_tys tycon
= newImplicitBinder src_name mkDataConWrapperOcc `thenM` \ wrap_name ->
newImplicitBinder src_name mkDataConWorkerOcc `thenM` \ work_name ->
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
-- This last one takes the name of the data constructor in the source
-- code, which (for Haskell source anyway) will be in the SrcDataName name
-- space, and makes it into a "real data constructor name"
let
; let
-- Make the FieldLabels
-- The zipLazy avoids forcing the arg_tys too early
final_lbls = [ mkFieldLabel name tycon ty tag
| ((name, tag), ty) <- (field_lbl_names `zip` allFieldLabelTags)
`zipLazy` arg_tys
]
ctxt' = thinContext arg_tys ctxt
data_con = mkDataCon src_name arg_stricts final_lbls
tyvars ctxt'
ex_tyvars ex_ctxt
arg_tys tycon dc_ids
dc_ids = mkDataConIds wrap_name work_name data_con
in
returnM data_con
final_lbls = [ mkFieldLabel name tycon ty tag
| ((name, tag), ty) <- (field_lbl_names `zip` allFieldLabelTags)
`zipLazy` arg_tys
]
ctxt' = thinContext arg_tys ctxt
data_con = mkDataCon src_name declared_infix
arg_stricts final_lbls
tyvars ctxt'
ex_tyvars ex_ctxt
arg_tys tycon dc_ids
dc_ids = mkDataConIds wrap_name work_name data_con
; returnM data_con }
-- The context for a data constructor should be limited to
-- the type variables mentioned in the arg_tys
......@@ -175,7 +177,7 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs
| (op_name, dm_info, _) <- sig_stuff ] }
-- Build the selector id and default method id
; dict_con <- buildDataCon datacon_name
; dict_con <- buildDataCon datacon_name False {- Not declared infix -}
(map (const NotMarkedStrict) dict_component_tys)
[{- No labelled fields -}]
tvs [{-No context-}]
......
......@@ -55,7 +55,7 @@ import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCo
tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn,
tyConArity, tyConTyVars, algTyConRhs, tyConExtName )
import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
dataConTyCon )
dataConTyCon, dataConIsInfix )
import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv,
lookupOccEnv, extendOccEnv, emptyOccEnv,
......@@ -138,6 +138,7 @@ visibleIfConDecls (IfNewTyCon c) = [c]
data IfaceConDecl
= IfaceConDecl OccName -- Constructor name
Bool -- True <=> declared infix
[IfaceTvBndr] -- Existental tyvars
IfaceContext -- Existential context
[IfaceType] -- Arg types
......@@ -286,9 +287,10 @@ pp_condecls (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map
pp_condecls (IfNewTyCon c) = equals <+> ppr c
instance Outputable IfaceConDecl where
ppr (IfaceConDecl name ex_tvs ex_ctxt arg_tys strs fields)
ppr (IfaceConDecl name is_infix ex_tvs ex_ctxt arg_tys strs fields)
= pprIfaceForAllPart ex_tvs ex_ctxt $
sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
if is_infix then ptext SLIT("Infix") else empty,
if null strs then empty
else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
if null fields then empty
......@@ -492,6 +494,7 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon)
ifaceConDecl data_con
= IfaceConDecl (getOccName (dataConName data_con))
(dataConIsInfix data_con)
(toIfaceTvBndrs ex_tyvars)
(toIfaceContext ext ex_theta)
(map (toIfaceType ext) arg_tys)
......@@ -781,9 +784,9 @@ eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
eq_hsCD env d1 d2 = NotEqual
eq_ConDecl env (IfaceConDecl n1 tvs1 cxt1 args1 ss1 lbls1)
(IfaceConDecl n2 tvs2 cxt2 args2 ss2 lbls2)
= bool (n1 == n2 && ss1 == ss2 && lbls1 == lbls2) &&&
eq_ConDecl env (IfaceConDecl n1 inf1 tvs1 cxt1 args1 ss1 lbls1)
(IfaceConDecl n2 inf2 tvs2 cxt2 args2 ss2 lbls2)
= bool (n1 == n2 && inf1 == inf2 && ss1 == ss2 && lbls1 == lbls2) &&&
eq_ifTvBndrs env tvs1 tvs2 (\ env ->
eq_ifContext env cxt1 cxt2 &&&
eq_ifTypes env args1 args2)
......
......@@ -306,7 +306,7 @@ ifaceDeclSubBndrs (IfaceData {ifCons = cons}) = foldr ((++) . conDeclBndrs) []
(visibleIfConDecls cons)
ifaceDeclSubBndrs other = []
conDeclBndrs (IfaceConDecl con_occ _ _ _ _ fields)
conDeclBndrs (IfaceConDecl con_occ _ _ _ _ _ fields)
= fields ++
[con_occ, mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ]
......
......@@ -535,7 +535,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers,
eq_ind_occs [op | IfaceClassOp op _ _ <- sigs]
eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons})
= same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too
eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ <- visibleIfConDecls cons]
eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ _ <- visibleIfConDecls cons]
eq_indirects other = Equal -- Synonyms and foreign declarations
eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules
......
......@@ -423,7 +423,7 @@ tcIfaceDataCons tycon tyvars ctxt if_cons
IfNewTyCon con -> do { data_con <- tc_con_decl con
; return (mkNewTyConRhs data_con) }
where
tc_con_decl (IfaceConDecl occ ex_tvs ex_ctxt args stricts field_lbls)
tc_con_decl (IfaceConDecl occ is_infix ex_tvs ex_ctxt args stricts field_lbls)
= bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
{ name <- lookupIfaceTop occ
; ex_theta <- tcIfaceCtxt ex_ctxt -- Laziness seems not worth the bother here
......@@ -434,7 +434,7 @@ tcIfaceDataCons tycon tyvars ctxt if_cons
; lbl_names <- mappM lookupIfaceTop field_lbls
; buildDataCon name stricts lbl_names
; buildDataCon name is_infix stricts lbl_names
tyvars ctxt ex_tyvars ex_theta
arg_tys tycon
}
......
......@@ -273,17 +273,17 @@ hsIfaceCons NewType [con] -- newtype
hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
= IfaceConDecl (get_occ lname)
= IfaceConDecl (get_occ lname) is_infix
(hsIfaceTvs ex_tvs)
(hsIfaceCtxt (unLoc ex_ctxt))
(map (hsIfaceLType . getBangType . unLoc) args)
(map (hsStrictMark . getBangStrictness . unLoc) args)
flds
where
(args, flds) = case details of
PrefixCon args -> (args, [])
InfixCon a1 a2 -> ([a1,a2], [])
RecCon fs -> (map snd fs, map (get_occ . fst) fs)
(is_infix, args, flds) = case details of
PrefixCon args -> (False, args, [])
InfixCon a1 a2 -> (True, [a1,a2], [])
RecCon fs -> (False, map snd fs, map (get_occ . fst) fs)
get_occ lname = rdrNameOcc (unLoc lname)
hsStrictMark :: HsBang -> StrictnessMark
......
......@@ -69,7 +69,8 @@ import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons,
mkTupleTyCon, mkAlgTyCon, tyConName
)
import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) )
import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..),
Fixity(..), FixityDirection(..), defaultFixity )
import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys,
ThetaType, TyThing(..) )
......@@ -181,7 +182,10 @@ pcTyCon is_enum is_rec name tyvars argvrcs cons
is_rec
True -- All the wired-in tycons have generics
pcDataCon :: Name -> [TyVar] -> ThetaType -> [Type] -> TyCon -> DataCon
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataCon = pcDataConWithFixity False
pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon
-- The Name should be in the DataName name space; it's the name
-- of the DataCon itself.
--
......@@ -189,13 +193,13 @@ pcDataCon :: Name -> [TyVar] -> ThetaType -> [Type] -> TyCon -> DataCon
-- the first is used for the datacon itself,
-- the second is used for the "worker name"
pcDataCon dc_name tyvars context arg_tys tycon
pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon
= data_con
where
data_con = mkDataCon dc_name
data_con = mkDataCon dc_name declared_infix
(map (const NotMarkedStrict) arg_tys)
[{- No labelled fields -}]
tyvars context [] [] arg_tys tycon
tyvars [] [] [] arg_tys tycon
(mkDataConIds bogus_wrap_name wrk_name data_con)
mod = nameModule dc_name
......@@ -244,7 +248,7 @@ mk_tuple boxity arity = (tycon, tuple_con)
tyvars | isBoxed boxity = take arity alphaTyVars
| otherwise = take arity openAlphaTyVars
tuple_con = pcDataCon dc_name tyvars [] tyvar_tys tycon
tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon
tyvar_tys = mkTyVarTys tyvars
dc_name = mkWiredInName mod (mkTupleOcc dataName boxity arity) dc_uniq
(Just tc_name) (ADataCon tuple_con)
......@@ -292,7 +296,7 @@ voidTy = unitTy
charTy = mkTyConTy charTyCon
charTyCon = pcNonRecDataTyCon charTyConName [] [] [charDataCon]
charDataCon = pcDataCon charDataConName [] [] [charPrimTy] charTyCon
charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
stringTy = mkListTy charTy -- convenience only
\end{code}
......@@ -301,21 +305,21 @@ stringTy = mkListTy charTy -- convenience only
intTy = mkTyConTy intTyCon
intTyCon = pcNonRecDataTyCon intTyConName [] [] [intDataCon]
intDataCon = pcDataCon intDataConName [] [] [intPrimTy] intTyCon
intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
\end{code}
\begin{code}
floatTy = mkTyConTy floatTyCon
floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon]
floatDataCon = pcDataCon floatDataConName [] [] [floatPrimTy] floatTyCon
floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon
\end{code}
\begin{code}
doubleTy = mkTyConTy doubleTyCon
doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [] [doubleDataCon]
doubleDataCon = pcDataCon doubleDataConName [] [] [doublePrimTy] doubleTyCon
doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
\end{code}
......@@ -373,8 +377,8 @@ boolTy = mkTyConTy boolTyCon
boolTyCon = pcTyCon True NonRecursive boolTyConName
[] [] [falseDataCon, trueDataCon]
falseDataCon = pcDataCon falseDataConName [] [] [] boolTyCon
trueDataCon = pcDataCon trueDataConName [] [] [] boolTyCon
falseDataCon = pcDataCon falseDataConName [] [] boolTyCon
trueDataCon = pcDataCon trueDataConName [] [] boolTyCon
falseDataConId = dataConWorkId falseDataCon
trueDataConId = dataConWorkId trueDataCon
......@@ -402,9 +406,10 @@ mkListTy ty = mkTyConApp listTyCon [ty]
listTyCon = pcRecDataTyCon listTyConName
alpha_tyvar [(True,False)] [nilDataCon, consDataCon]
nilDataCon = pcDataCon nilDataConName alpha_tyvar [] [] listTyCon
consDataCon = pcDataCon consDataConName
alpha_tyvar [] [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon
consDataCon = pcDataConWithFixity True {- Declared infix -}
consDataConName
alpha_tyvar [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
-- Interesting: polymorphic recursion would help here.
-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
-- gets the over-specific type (Type -> Type)
......@@ -493,7 +498,6 @@ parrDataCon :: DataCon
parrDataCon = pcDataCon
parrDataConName
alpha_tyvar -- forall'ed type variables
[] -- context
[intPrimTy, -- 1st argument: Int#
mkTyConApp -- 2nd argument: Array# a
arrayPrimTyCon
......@@ -527,7 +531,7 @@ parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i)
mkPArrFakeCon :: Int -> DataCon
mkPArrFakeCon arity = data_con
where
data_con = pcDataCon name [tyvar] [] tyvarTys parrTyCon
data_con = pcDataCon name [tyvar] tyvarTys parrTyCon
tyvar = head alphaTyVars
tyvarTys = replicate arity $ mkTyVarTy tyvar
nameStr = mkFastString ("MkPArr" ++ show arity)
......
......@@ -35,7 +35,7 @@ import BasicTypes ( Fixity(..), maxPrecedence, Boxity(..) )
import FieldLabel ( fieldLabelName )
import DataCon ( isNullaryDataCon, dataConTag,
dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
DataCon, dataConName,
DataCon, dataConName, dataConIsInfix,
dataConFieldLabels )
import Name ( getOccString, getSrcLoc, Name, NamedThing(..) )
......@@ -780,7 +780,7 @@ gen_Read_binds get_fixity tycon
| otherwise = prefix_stmts
prefix_stmts -- T a b c
= [bindLex (ident_pat (data_con_str data_con))]
= [bindLex (ident_pat (data_con_str_w_parens data_con))]
++ read_args
++ [result_stmt data_con as_needed]
......@@ -791,7 +791,7 @@ gen_Read_binds get_fixity tycon
result_stmt data_con [a1,a2]]
lbl_stmts -- T { f1 = a, f2 = b }
= [bindLex (ident_pat (data_con_str data_con)),
= [bindLex (ident_pat (data_con_str_w_parens data_con)),
read_punc "{"]
++ concat (intersperse [read_punc ","] field_stmts)
++ [read_punc "}", result_stmt data_con as_needed]
......@@ -801,7 +801,7 @@ gen_Read_binds get_fixity tycon
con_arity = dataConSourceArity data_con
labels = dataConFieldLabels data_con
dc_nm = getName data_con
is_infix = isDataSymOcc (getOccName dc_nm)
is_infix = dataConIsInfix data_con
as_needed = take con_arity as_RDRs
read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
(read_a1:read_a2:_) = read_args
......@@ -820,7 +820,8 @@ gen_Read_binds get_fixity tycon
ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo"
symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>"
data_con_str con = mkHsString (occNameUserString (getOccName con))
data_con_str con = mkHsString (occNameUserString (getOccName con))
data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con))
read_punc c = bindLex (punc_pat c)
read_arg a ty
......@@ -913,24 +914,22 @@ gen_Show_binds get_fixity tycon
dc_nm = getName data_con
dc_occ_nm = getOccName data_con
con_str = occNameUserString dc_occ_nm
op_con_str = occNameUserString_with_parens dc_occ_nm
show_thingies
| is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
| record_syntax = mk_showString_app (con_str ++ " {") :
| record_syntax = mk_showString_app (op_con_str ++ " {") :
show_record_args ++ [mk_showString_app "}"]
| otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
| otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
show_label l = mk_showString_app (the_name ++ " = ")
show_label l = mk_showString_app (nm ++ " = ")
-- Note the spaces around the "=" sign. If we don't have them
-- then we get Foo { x=-1 } and the "=-" parses as a single
-- lexeme. Only the space after the '=' is necessary, but
-- it seems tidier to have them both sides.
where
occ_nm = getOccName (fieldLabelName l)
nm = occNameUserString occ_nm
is_op = isSymOcc occ_nm -- Legal, but rare.
the_name | is_op = '(':nm ++ ")"
| otherwise = nm
nm = occNameUserString_with_parens occ_nm
show_args = zipWith show_arg bs_needed arg_tys
(show_arg1:show_arg2:_) = show_args
......@@ -951,11 +950,18 @@ gen_Show_binds get_fixity tycon
box_if_necy "Show" tycon (nlHsVar b) arg_ty]
-- Fixity stuff
is_infix = isDataSymOcc dc_occ_nm
is_infix = dataConIsInfix data_con
con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
arg_prec | record_syntax = 0 -- Record fields don't need parens
| otherwise = con_prec_plus_one
occNameUserString_with_parens :: OccName -> String
occNameUserString_with_parens occ
| isSymOcc occ = '(':nm ++ ")"
| otherwise = nm
where
nm = occNameUserString occ
mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
\end{code}
......
......@@ -907,8 +907,8 @@ filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
filter_decl occs decl
= decl
keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
keep_con occs (IfaceConDecl occ _ _ _ _ _) = occ `elem` occs
keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs
availOccs avail = map nameOccName (availNames avail)
......
......@@ -43,7 +43,7 @@ import IfaceEnv ( lookupOrig )
import Class ( Class, classBigSig )
import TyCon ( TyCon, tyConTheta, tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks,
dataConName, dataConFieldLabels, dataConWrapId )
dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix )
import Id ( idName, globalIdDetails )
import IdInfo ( GlobalIdDetails(..) )
import TysWiredIn ( mkListTy )
......@@ -549,11 +549,18 @@ reifyDataCon dc
= do { arg_tys <- reifyTypes (dataConOrigArgTys dc)
; let stricts = map reifyStrict (dataConStrictMarks dc)
fields = dataConFieldLabels dc
; if null fields then
return (TH.NormalC (reifyName dc) (stricts `zip` arg_tys))
name = reifyName dc
[a1,a2] = arg_tys
[s1,s2] = stricts
; ASSERT( length arg_tys == length stricts )
if not (null fields) then
return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
else
return (TH.RecC (reifyName dc) (zip3 (map reifyName fields) stricts arg_tys)) }
-- NB: we don't remember whether the constructor was declared in an infix way
if dataConIsInfix dc then
ASSERT( length arg_tys == 2 )
return (TH.InfixC (s1,a1) name (s1,a2))
else
return (TH.NormalC name (stricts `zip` arg_tys)) }
------------------------------
reifyClass :: Class -> TcM TH.Dec
......
......@@ -16,7 +16,7 @@ import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
LTyClDecl, tcdName, LHsTyVarBndr
)
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
import HscTypes ( implicitTyThings )
import HscTypes ( implicitTyThings, lookupFixity )
import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
......@@ -414,20 +414,20 @@ tcConDecl new_or_data tycon tyvars ctxt
{ ex_ctxt' <- tcHsKindedContext ex_ctxt
; unbox_strict <- doptM Opt_UnboxStrictFields
; let
tc_datacon field_lbls btys
tc_datacon is_infix field_lbls btys
= do { let { ubtys = map unLoc btys }
; arg_tys <- mappM (tcHsKindedType . getBangType) ubtys
; buildDataCon (unLoc name)
; buildDataCon (unLoc name) is_infix
(argStrictness unbox_strict tycon ubtys arg_tys)
(map unLoc field_lbls)
tyvars ctxt ex_tvs' ex_ctxt'
arg_tys tycon }
; case details of
PrefixCon btys -> tc_datacon [] btys
InfixCon bty1 bty2 -> tc_datacon [] [bty1,bty2]
PrefixCon btys -> tc_datacon False [] btys
InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
RecCon fields -> do { checkTc (null ex_tvs') (exRecConErr name)
; let { (field_names, btys) = unzip fields }
; tc_datacon field_names btys } }
; tc_datacon False field_names btys } }
argStrictness :: Bool -- True <=> -funbox-strict_fields
-> TyCon -> [BangType Name]
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment