dataConRepArgTys, dataConTheta,
dataConFieldLabels, dataConStrictMarks, dataConExStricts,
dataConSourceArity, dataConRepArity,
- dataConNumInstArgs,
+ dataConNumInstArgs, dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness,
isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
--
-- 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
\begin{code}
mkDataCon :: Name
+ -> Bool -- Declared infix
-> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType
-> [TyVar] -> ThetaType
-> 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
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*,
dataConRepType :: DataCon -> Type
dataConRepType = dcRepType
+dataConIsInfix :: DataCon -> Bool
+dataConIsInfix = dcInfix
+
dataConWorkId :: DataCon -> Id
dataConWorkId dc = case dcIds dc of
AlgDC _ wrk_id -> wrk_id
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
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
------------------------------------------------------
-buildDataCon :: Name
+buildDataCon :: Name -> Bool
-> [StrictnessMark]
-> [Name] -- Field labels
-> [TyVar] -> ThetaType
-- 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
| (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-}]
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,
data IfaceConDecl
= IfaceConDecl OccName -- Constructor name
+ Bool -- True <=> declared infix
[IfaceTvBndr] -- Existental tyvars
IfaceContext -- Existential context
[IfaceType] -- Arg types
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
ifaceConDecl data_con
= IfaceConDecl (getOccName (dataConName data_con))
+ (dataConIsInfix data_con)
(toIfaceTvBndrs ex_tyvars)
(toIfaceContext ext ex_theta)
(map (toIfaceType ext) arg_tys)
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)
(visibleIfConDecls cons)
ifaceDeclSubBndrs other = []
-conDeclBndrs (IfaceConDecl con_occ _ _ _ _ fields)
+conDeclBndrs (IfaceConDecl con_occ _ _ _ _ _ fields)
= fields ++
[con_occ, mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ]
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
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
; 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
}
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
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(..) )
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.
--
-- 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
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)
charTy = mkTyConTy charTyCon
charTyCon = pcNonRecDataTyCon charTyConName [] [] [charDataCon]
-charDataCon = pcDataCon charDataConName [] [] [charPrimTy] charTyCon
+charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
stringTy = mkListTy charTy -- convenience only
\end{code}
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}
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
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)
parrDataCon = pcDataCon
parrDataConName
alpha_tyvar -- forall'ed type variables
- [] -- context
[intPrimTy, -- 1st argument: Int#
mkTyConApp -- 2nd argument: Array# a
arrayPrimTyCon
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)
import FieldLabel ( fieldLabelName )
import DataCon ( isNullaryDataCon, dataConTag,
dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
- DataCon, dataConName,
+ DataCon, dataConName, dataConIsInfix,
dataConFieldLabels )
import Name ( getOccString, getSrcLoc, Name, NamedThing(..) )
| 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]
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]
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
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
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
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}
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)
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 )
= 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
LTyClDecl, tcdName, LHsTyVarBndr
)
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
-import HscTypes ( implicitTyThings )
+import HscTypes ( implicitTyThings, lookupFixity )
import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
{ 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]
projects / ghc-hetmet.git / commitdiff