X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=2c1ce9e9eea4f42b665a5fb0cb7657f080ec1048;hb=3f1b316d7035c55cd712cd39a9981339bcef2e8c;hp=40e091d475fcdf9e93cb8d499646a1f9e2fd538f;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 40e091d..2c1ce9e 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcGenDeriv]{Generating derived instance declarations} + +TcGenDeriv: Generating derived instance declarations This module is nominally ``subordinate'' to @TcDeriv@, which is the ``official'' interface to deriving-related things. @@ -9,7 +11,16 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the This is where we do all the grimy bindings' generation. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcGenDeriv ( + DerivAuxBind(..), DerivAuxBinds, isDupAux, + gen_Bounded_binds, gen_Enum_binds, gen_Eq_binds, @@ -19,58 +30,58 @@ module TcGenDeriv ( gen_Show_binds, gen_Data_binds, gen_Typeable_binds, - gen_tag_n_con_monobind, - - con2tag_RDR, tag2con_RDR, maxtag_RDR, + genAuxBind, - TagThingWanted(..) + con2tag_RDR, tag2con_RDR, maxtag_RDR ) where #include "HsVersions.h" import HsSyn -import RdrName ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual, - mkDerivedRdrName ) -import BasicTypes ( Fixity(..), maxPrecedence, Boxity(..) ) -import DataCon ( isNullarySrcDataCon, dataConTag, - dataConOrigArgTys, dataConSourceArity, fIRST_TAG, - DataCon, dataConName, dataConIsInfix, - dataConFieldLabels ) -import Name ( getOccString, getSrcLoc, Name, NamedThing(..) ) - -import HscTypes ( FixityEnv, lookupFixity ) +import RdrName +import BasicTypes +import DataCon +import Name + +import HscTypes import PrelInfo import PrelNames -import MkId ( eRROR_ID ) -import PrimOp ( PrimOp(..) ) -import SrcLoc ( Located(..), noLoc, srcLocSpan ) -import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity, - maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName - ) -import TcType ( isUnLiftedType, tcEqType, Type ) -import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, - intPrimTyCon ) -import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon, - intDataCon_RDR, true_RDR, false_RDR ) -import Util ( zipWithEqual, isSingleton, - zipWith3Equal, nOfThem, zipEqual ) -import Constants -import List ( partition, intersperse ) +import MkId +import PrimOp +import SrcLoc +import TyCon +import TcType +import TysPrim +import TysWiredIn +import Util import Outputable import FastString import OccName import Bag + +import Data.List ( partition, intersperse ) +\end{code} + +\begin{code} +type DerivAuxBinds = [DerivAuxBind] + +data DerivAuxBind -- Please add these auxiliary top-level bindings + = DerivAuxBind (LHsBind RdrName) + | GenCon2Tag TyCon -- The con2Tag for given TyCon + | GenTag2Con TyCon -- ...ditto tag2Con + | GenMaxTag TyCon -- ...and maxTag + +isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool +isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1==tc2 +isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1==tc2 +isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1==tc2 +isDupAux b1 b2 = False \end{code} -%************************************************************************ -%* * -\subsection{Generating code, by derivable class} -%* * -%************************************************************************ %************************************************************************ %* * -\subsubsection{Generating @Eq@ instance declarations} + Eq instances %* * %************************************************************************ @@ -143,33 +154,36 @@ instance ... Eq (Foo ...) where \begin{code} -gen_Eq_binds :: TyCon -> LHsBinds RdrName - +gen_Eq_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Eq_binds tycon - = let - tycon_loc = getSrcSpan tycon - - (nullary_cons, nonnullary_cons) - | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) - - rest - = if (null nullary_cons) then - case maybeTyConSingleCon tycon of - Just _ -> [] - Nothing -> -- if cons don't match, then False - [([nlWildPat, nlWildPat], false_Expr)] - else -- calc. and compare the tags - [([a_Pat, b_Pat], - untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] - in - listToBag [ - mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), - mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] ( - nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) - ] + = (method_binds, aux_binds) where + tycon_loc = getSrcSpan tycon + + (nullary_cons, nonnullary_cons) + | isNewTyCon tycon = ([], tyConDataCons tycon) + | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) + + no_nullary_cons = null nullary_cons + + rest | no_nullary_cons + = case maybeTyConSingleCon tycon of + Just _ -> [] + Nothing -> -- if cons don't match, then False + [([nlWildPat, nlWildPat], false_Expr)] + | otherwise -- calc. and compare the tags + = [([a_Pat, b_Pat], + untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] + + aux_binds | no_nullary_cons = [] + | otherwise = [GenCon2Tag tycon] + + method_binds = listToBag [ + mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), + mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] ( + nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))] + ------------------------------------------------------------------ pats_etc data_con = let @@ -193,7 +207,7 @@ gen_Eq_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Ord@ instance declarations} + Ord instances %* * %************************************************************************ @@ -288,14 +302,17 @@ If there is only one constructor in the Data Type we don't need the WildCard Pat JJQC-30-Nov-1997 \begin{code} -gen_Ord_binds :: TyCon -> LHsBinds RdrName +gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Ord_binds tycon - = unitBag compare -- `AndMonoBinds` compare - -- The default declaration in PrelBase handles this + = (unitBag compare, aux_binds) + -- `AndMonoBinds` compare + -- The default declaration in PrelBase handles this where tycon_loc = getSrcSpan tycon -------------------------------------------------------------------- + aux_binds | single_con_type = [] + | otherwise = [GenCon2Tag tycon] compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches) compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds] @@ -333,36 +350,37 @@ gen_Ord_binds tycon else [([nlWildPat, nlWildPat], default_rhs)]) - where - pats_etc data_con - = ([con1_pat, con2_pat], - nested_compare_expr tys_needed as_needed bs_needed) - where - con1_pat = nlConVarPat data_con_RDR as_needed - con2_pat = nlConVarPat data_con_RDR bs_needed + default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about + -- inexhaustive patterns + | otherwise = eqTag_Expr -- Some nullary constructors; + -- Tags are equal, no args => return EQ + pats_etc data_con + = ([con1_pat, con2_pat], + nested_compare_expr tys_needed as_needed bs_needed) + where + con1_pat = nlConVarPat data_con_RDR as_needed + con2_pat = nlConVarPat data_con_RDR bs_needed - data_con_RDR = getRdrName data_con - con_arity = length tys_needed - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - tys_needed = dataConOrigArgTys data_con + data_con_RDR = getRdrName data_con + con_arity = length tys_needed + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + tys_needed = dataConOrigArgTys data_con - nested_compare_expr [ty] [a] [b] - = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b) + nested_compare_expr [ty] [a] [b] + = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b) - nested_compare_expr (ty:tys) (a:as) (b:bs) - = let eq_expr = nested_compare_expr tys as bs + nested_compare_expr (ty:tys) (a:as) (b:bs) + = let eq_expr = nested_compare_expr tys as bs in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) - default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about - -- inexhaustive patterns - | otherwise = eqTag_Expr -- Some nullary constructors; - -- Tags are equal, no args => return EQ + nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length + \end{code} %************************************************************************ %* * -\subsubsection{Generating @Enum@ instance declarations} + Enum instances %* * %************************************************************************ @@ -402,18 +420,20 @@ instance ... Enum (Foo ...) where For @enumFromTo@ and @enumFromThenTo@, we use the default methods. \begin{code} -gen_Enum_binds :: TyCon -> LHsBinds RdrName - +gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Enum_binds tycon - = listToBag [ - succ_enum, - pred_enum, - to_enum, - enum_from, - enum_from_then, - from_enum - ] + = (method_binds, aux_binds) where + method_binds = listToBag [ + succ_enum, + pred_enum, + to_enum, + enum_from, + enum_from_then, + from_enum + ] + aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon] + tycon_loc = getSrcSpan tycon occ_nm = getOccString tycon @@ -475,17 +495,18 @@ gen_Enum_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Bounded@ instance declarations} + Bounded instances %* * %************************************************************************ \begin{code} +gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Bounded_binds tycon - = if isEnumerationTyCon tycon then - listToBag [ min_bound_enum, max_bound_enum ] - else - ASSERT(isSingleton data_cons) - listToBag [ min_bound_1con, max_bound_1con ] + | isEnumerationTyCon tycon + = (listToBag [ min_bound_enum, max_bound_enum ], []) + | otherwise + = ASSERT(isSingleton data_cons) + (listToBag [ min_bound_1con, max_bound_1con ], []) where data_cons = tyConDataCons tycon tycon_loc = getSrcSpan tycon @@ -510,7 +531,7 @@ gen_Bounded_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Ix@ instance declarations} + Ix instances %* * %************************************************************************ @@ -567,12 +588,13 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). \begin{code} -gen_Ix_binds :: TyCon -> LHsBinds RdrName +gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Ix_binds tycon - = if isEnumerationTyCon tycon - then enum_ixes - else single_con_ixes + | isEnumerationTyCon tycon + = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]) + | otherwise + = (single_con_ixes, [GenCon2Tag tycon]) where tycon_loc = getSrcSpan tycon @@ -683,7 +705,7 @@ gen_Ix_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Read@ instance declarations} + Read instances %* * %************************************************************************ @@ -692,7 +714,7 @@ Example infix 4 %% data T = Int %% Int | T1 { f1 :: Int } - | T2 Int + | T2 T instance Read T where @@ -704,7 +726,9 @@ instance Read T where y <- ReadP.step Read.readPrec return (x %% y)) +++ - prec appPrec ( + prec (appPrec+1) ( + -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok + -- Record construction binds even more tightly than application do Ident "T1" <- Lex.lex Punc '{' <- Lex.lex Ident "f1" <- Lex.lex @@ -724,10 +748,10 @@ instance Read T where \begin{code} -gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName +gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Read_binds get_fixity tycon - = listToBag [read_prec, default_readlist, default_readlistprec] + = (listToBag [read_prec, default_readlist, default_readlistprec], []) where ----------------------------------------------------------------------- default_readlist @@ -753,24 +777,29 @@ gen_Read_binds get_fixity tycon [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))] (result_expr con [])] _ -> [nlHsApp (nlHsVar choose_RDR) - (nlList (map mk_pair nullary_cons))] + (nlList (map mk_pair nullary_cons))] - mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), - nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))] - Boxed + mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), + result_expr con []] + Boxed read_non_nullary_con data_con - = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body] + | is_infix = mk_parser infix_prec infix_stmts body + | is_record = mk_parser record_prec record_stmts body +-- Using these two lines instead allows the derived +-- read for infix and record bindings to read the prefix form +-- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) +-- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) + | otherwise = prefix_parser where - stmts | is_infix = infix_stmts - | length labels > 0 = lbl_stmts - | otherwise = prefix_stmts - body = result_expr data_con as_needed con_str = data_con_str data_con + prefix_parser = mk_parser prefix_prec prefix_stmts body prefix_stmts -- T a b c - = [bindLex (ident_pat (wrapOpParens con_str))] + = (if not (isSym con_str) then + [bindLex (ident_pat con_str)] + else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]) ++ read_args infix_stmts -- a %% b, or a `T` b @@ -780,7 +809,7 @@ gen_Read_binds get_fixity tycon else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]) ++ [read_a2] - lbl_stmts -- T { f1 = a, f2 = b } + record_stmts -- T { f1 = a, f2 = b } = [bindLex (ident_pat (wrapOpParens con_str)), read_punc "{"] ++ concat (intersperse [read_punc ","] field_stmts) @@ -792,18 +821,24 @@ gen_Read_binds get_fixity tycon labels = dataConFieldLabels data_con dc_nm = getName data_con is_infix = dataConIsInfix data_con + is_record = length labels > 0 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 - prec = getPrec is_infix get_fixity dc_nm + + prefix_prec = appPrecedence + infix_prec = getPrecedence get_fixity dc_nm + record_prec = appPrecedence + 1 -- Record construction binds even more tightly + -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) ------------------------------------------------------------------------ -- Helpers ------------------------------------------------------------------------ - mk_alt e1 e2 = genOpApp e1 alt_RDR e2 - bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) - con_app c as = nlHsVarApps (getRdrName c) as - result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as) + mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 + mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b }) + bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP + con_app con as = nlHsVarApps (getRdrName con) as -- con as + result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" @@ -838,7 +873,7 @@ gen_Read_binds get_fixity tycon %************************************************************************ %* * -\subsubsection{Generating @Show@ instance declarations} + Show instances %* * %************************************************************************ @@ -866,10 +901,10 @@ Example -- the most tightly-binding operator \begin{code} -gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName +gen_Show_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Show_binds get_fixity tycon - = listToBag [shows_prec, show_list] + = (listToBag [shows_prec, show_list], []) where tycon_loc = getSrcSpan tycon ----------------------------------------------------------------------- @@ -971,7 +1006,10 @@ appPrecedence = fromIntegral maxPrecedence + 1 getPrecedence :: FixityEnv -> Name -> Integer getPrecedence get_fixity nm = case lookupFixity get_fixity nm of - Fixity x _ -> fromIntegral x + Fixity x _assoc -> fromIntegral x + -- NB: the Report says that associativity is not taken + -- into account for either Read or Show; hence we + -- ignore associativity here \end{code} @@ -1017,7 +1055,7 @@ mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix)) %************************************************************************ %* * -\subsection{Data} + Data instances %* * %************************************************************************ @@ -1050,11 +1088,11 @@ we generate gen_Data_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, -- The method bindings - LHsBinds RdrName) -- Auxiliary bindings + DerivAuxBinds) -- Auxiliary bindings gen_Data_binds fix_env tycon = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind], -- Auxiliary definitions: the data type and constructors - datatype_bind `consBag` listToBag (map mk_con_bind data_cons)) + DerivAuxBind datatype_bind : map mk_con_bind data_cons) where tycon_loc = getSrcSpan tycon tycon_name = tyConName tycon @@ -1121,7 +1159,8 @@ gen_Data_binds fix_env tycon ------------ $cT1 etc mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc - mk_con_bind dc = mkVarBind + mk_con_bind dc = DerivAuxBind $ + mkVarBind tycon_loc (mk_constr_name dc) (nlHsApps mkConstr_RDR (constr_args dc)) @@ -1168,16 +1207,12 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. \begin{code} -data TagThingWanted - = GenCon2Tag | GenTag2Con | GenMaxTag +genAuxBind :: DerivAuxBind -> LHsBind RdrName -gen_tag_n_con_monobind - :: ( RdrName, -- (proto)Name for the thing in question - TyCon, -- tycon in question - TagThingWanted) - -> LHsBind RdrName +genAuxBind (DerivAuxBind bind) + = bind -gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) +genAuxBind (GenCon2Tag tycon) | lots_of_constructors = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)] @@ -1185,6 +1220,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon)) where + rdr_name = con2tag_RDR tycon tycon_loc = getSrcSpan tycon tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon) @@ -1199,30 +1235,33 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) (nlHsApp (nlHsVar getTag_RDR) a_Expr))) (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty)) - con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon)) - (map nlHsTyVar tvs) + con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs) `nlHsFunTy` nlHsTyVar (getRdrName intPrimTyCon) - lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS + lots_of_constructors = tyConFamilySize tycon > 8 + -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS + -- but we don't do vectored returns any more. mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName) mk_stuff con = ([nlWildConPat con], nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) -gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) +genAuxBind (GenTag2Con tycon) = mk_FunBind (getSrcSpan tycon) rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr) (nlHsTyVar (getRdrName tycon))))] + where + rdr_name = tag2con_RDR tycon -gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) +genAuxBind (GenMaxTag tycon) = mkVarBind (getSrcSpan tycon) rdr_name (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))) where + rdr_name = maxtag_RDR tycon max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) - \end{code} %************************************************************************ @@ -1316,7 +1355,6 @@ box_con_tbl = [(charPrimTy, getRdrName charDataCon) ,(intPrimTy, getRdrName intDataCon) ,(wordPrimTy, wordDataCon_RDR) - ,(addrPrimTy, addrDataCon_RDR) ,(floatPrimTy, getRdrName floatDataCon) ,(doublePrimTy, getRdrName doubleDataCon) ] @@ -1371,6 +1409,7 @@ showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName +nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty nested_compose_Expr [e] = parenify e nested_compose_Expr (e:es) = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) @@ -1412,10 +1451,6 @@ genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) \end{code} \begin{code} -getSrcSpan = srcLocSpan . getSrcLoc -\end{code} - -\begin{code} a_RDR = mkVarUnqual FSLIT("a") b_RDR = mkVarUnqual FSLIT("b") c_RDR = mkVarUnqual FSLIT("c")