X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=2192531d3debec3ed80542fa637ddc49670812b5;hp=f2486745865a5370216c87346ebcd577507b504f;hb=58521c72cec262496dabf5fffb057d25ab17a0f7;hpb=ab5c770bed51f08d56a0d61086988053b21aa461 diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index f248674..2192531 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -11,15 +11,8 @@ 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, + DerivAuxBinds, isDupAux, gen_Bounded_binds, gen_Enum_binds, @@ -30,9 +23,12 @@ module TcGenDeriv ( gen_Show_binds, gen_Data_binds, gen_Typeable_binds, - genAuxBind, - - con2tag_RDR, tag2con_RDR, maxtag_RDR + gen_Functor_binds, + FFoldType(..), functorLikeTraverse, + deepSubtypesContaining, foldDataConArgs, + gen_Foldable_binds, + gen_Traversable_binds, + genAuxBind ) where #include "HsVersions.h" @@ -46,19 +42,22 @@ import Name import HscTypes import PrelInfo import PrelNames -import MkId import PrimOp import SrcLoc import TyCon import TcType import TysPrim import TysWiredIn +import Type +import Var( TyVar ) +import TypeRep +import VarSet +import State import Util +import MonadUtils import Outputable import FastString -import OccName import Bag - import Data.List ( partition, intersperse ) \end{code} @@ -66,16 +65,22 @@ import Data.List ( partition, intersperse ) type DerivAuxBinds = [DerivAuxBind] data DerivAuxBind -- Please add these auxiliary top-level bindings - = DerivAuxBind (LHsBind RdrName) - | GenCon2Tag TyCon -- The con2Tag for given TyCon + = GenCon2Tag TyCon -- The con2Tag for given TyCon | GenTag2Con TyCon -- ...ditto tag2Con | GenMaxTag TyCon -- ...and maxTag + -- Scrap your boilerplate + | MkDataCon DataCon -- For constructor C we get $cC :: Constr + | MkTyCon TyCon -- For tycon T we get $tT :: DataType + + 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 +isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2 +isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2 +isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2 +isDupAux (MkDataCon dc1) (MkDataCon dc2) = dc1 == dc2 +isDupAux (MkTyCon tc1) (MkTyCon tc2) = tc1 == tc2 +isDupAux _ _ = False \end{code} @@ -154,12 +159,10 @@ instance ... Eq (Foo ...) where \begin{code} -gen_Eq_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Eq_binds tycon +gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Eq_binds loc tycon = (method_binds, aux_binds) where - tycon_loc = getSrcSpan tycon - (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) @@ -167,7 +170,7 @@ gen_Eq_binds tycon no_nullary_cons = null nullary_cons rest | no_nullary_cons - = case maybeTyConSingleCon tycon of + = case tyConSingleDataCon_maybe tycon of Just _ -> [] Nothing -> -- if cons don't match, then False [([nlWildPat, nlWildPat], false_Expr)] @@ -180,8 +183,8 @@ gen_Eq_binds tycon | 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] ( + mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), + mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] ( nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))] ------------------------------------------------------------------ @@ -302,9 +305,9 @@ 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, DerivAuxBinds) +gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Ord_binds tycon +gen_Ord_binds loc tycon | Just (con, prim_tc) <- primWrapperType_maybe tycon = gen_PrimOrd_binds con prim_tc @@ -313,12 +316,10 @@ gen_Ord_binds tycon -- `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 = L loc (mkFunBind (L loc compare_RDR) compare_matches) compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds] cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) []) @@ -338,7 +339,7 @@ gen_Ord_binds tycon | isNewTyCon tycon = ([], tyConDataCons tycon) | otherwise = partition isNullarySrcDataCon tycon_data_cons - cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match + cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match cmp_eq_match | isEnumerationTyCon tycon -- We know the tags are equal, so if it's an enumeration TyCon, @@ -475,8 +476,8 @@ instance ... Enum (Foo ...) where For @enumFromTo@ and @enumFromThenTo@, we use the default methods. \begin{code} -gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Enum_binds tycon +gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Enum_binds loc tycon = (method_binds, aux_binds) where method_binds = listToBag [ @@ -489,11 +490,10 @@ gen_Enum_binds tycon ] aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon] - tycon_loc = getSrcSpan tycon - occ_nm = getOccString tycon + occ_nm = getOccString tycon succ_enum - = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $ + = mk_easy_FunBind loc succ_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon), nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -503,7 +503,7 @@ gen_Enum_binds tycon nlHsIntLit 1])) pred_enum - = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $ + = mk_easy_FunBind loc pred_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -513,7 +513,7 @@ gen_Enum_binds tycon nlHsLit (HsInt (-1))])) to_enum - = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $ + = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ nlHsIf (nlHsApps and_RDR [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]]) @@ -521,7 +521,7 @@ gen_Enum_binds tycon (illegal_toEnum_tag occ_nm (maxtag_RDR tycon)) enum_from - = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $ + = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsApps map_RDR [nlHsVar (tag2con_RDR tycon), @@ -530,7 +530,7 @@ gen_Enum_binds tycon (nlHsVar (maxtag_RDR tycon)))] enum_from_then - = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $ + = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ nlHsPar (enum_from_then_to_Expr @@ -543,7 +543,7 @@ gen_Enum_binds tycon )) from_enum - = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $ + = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) \end{code} @@ -555,8 +555,8 @@ gen_Enum_binds tycon %************************************************************************ \begin{code} -gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Bounded_binds tycon +gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Bounded_binds loc tycon | isEnumerationTyCon tycon = (listToBag [ min_bound_enum, max_bound_enum ], []) | otherwise @@ -564,11 +564,10 @@ gen_Bounded_binds tycon (listToBag [ min_bound_1con, max_bound_1con ], []) where data_cons = tyConDataCons tycon - tycon_loc = getSrcSpan tycon ----- enum-flavored: --------------------------- - min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR) + min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) data_con_1 = head data_cons data_con_N = last data_cons @@ -578,9 +577,9 @@ gen_Bounded_binds tycon ----- single-constructor-flavored: ------------- arity = dataConSourceArity data_con_1 - min_bound_1con = mkVarBind tycon_loc minBound_RDR $ + min_bound_1con = mkVarBind loc minBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) - max_bound_1con = mkVarBind tycon_loc maxBound_RDR $ + max_bound_1con = mkVarBind loc maxBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) \end{code} @@ -643,21 +642,19 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). \begin{code} -gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Ix_binds tycon +gen_Ix_binds loc tycon | isEnumerationTyCon tycon = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]) | otherwise = (single_con_ixes, [GenCon2Tag tycon]) where - tycon_loc = getSrcSpan tycon - -------------------------------------------------------------- enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ] enum_range - = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ + = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ @@ -666,7 +663,7 @@ gen_Ix_binds tycon (nlHsVarApps intDataCon_RDR [bh_RDR])) enum_index - = mk_easy_FunBind tycon_loc unsafeIndex_RDR + = mk_easy_FunBind loc unsafeIndex_RDR [noLoc (AsPat (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( @@ -682,7 +679,7 @@ gen_Ix_binds tycon ) enum_inRange - = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ + = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( @@ -697,11 +694,9 @@ gen_Ix_binds tycon = listToBag [single_con_range, single_con_index, single_con_inRange] data_con - = case maybeTyConSingleCon tycon of -- just checking... + = case tyConSingleDataCon_maybe tycon of -- just checking... Nothing -> panic "get_Ix_binds" - Just dc | any isUnLiftedType (dataConOrigArgTys dc) - -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon) - | otherwise -> dc + Just dc -> dc con_arity = dataConSourceArity data_con data_con_RDR = getRdrName data_con @@ -715,7 +710,7 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range - = mk_easy_FunBind tycon_loc range_RDR + = mk_easy_FunBind loc range_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ nlHsDo ListComp stmts con_expr where @@ -723,11 +718,11 @@ gen_Ix_binds tycon mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c) (nlHsApp (nlHsVar range_RDR) - (nlTuple [nlHsVar a, nlHsVar b] Boxed)) + (mkLHsVarTuple [a,b])) ---------------- single_con_index - = mk_easy_FunBind tycon_loc unsafeIndex_RDR + = mk_easy_FunBind loc unsafeIndex_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] -- We need to reverse the order we consider the components in @@ -745,21 +740,20 @@ gen_Ix_binds tycon ) plus_RDR ( genOpApp ( (nlHsApp (nlHsVar unsafeRangeSize_RDR) - (nlTuple [nlHsVar l, nlHsVar u] Boxed)) + (mkLHsVarTuple [l,u])) ) times_RDR (mk_index rest) ) mk_one l u i - = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i] + = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] ------------------ single_con_inRange - = mk_easy_FunBind tycon_loc inRange_RDR + = mk_easy_FunBind loc inRange_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] $ foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed) where - in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed, - nlHsVar c] + in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] \end{code} %************************************************************************ @@ -807,9 +801,9 @@ instance Read T where \begin{code} -gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Read_binds get_fixity tycon +gen_Read_binds get_fixity loc tycon = (listToBag [read_prec, default_readlist, default_readlistprec], []) where ----------------------------------------------------------------------- @@ -820,7 +814,6 @@ gen_Read_binds get_fixity tycon = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) ----------------------------------------------------------------------- - loc = getSrcSpan tycon data_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons @@ -838,9 +831,8 @@ gen_Read_binds get_fixity tycon _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] - mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), - result_expr con []] - Boxed + mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), + result_expr con []] read_non_nullary_con data_con | is_infix = mk_parser infix_prec infix_stmts body @@ -855,22 +847,26 @@ gen_Read_binds get_fixity tycon con_str = data_con_str data_con prefix_parser = mk_parser prefix_prec prefix_stmts body - prefix_stmts -- T a b c - = (if not (isSym con_str) then - [bindLex (ident_pat con_str)] - else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]) - ++ read_args + + read_prefix_con + | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"] + | otherwise = [bindLex (ident_pat con_str)] + read_infix_con + | isSym con_str = [bindLex (symbol_pat con_str)] + | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"] + + prefix_stmts -- T a b c + = read_prefix_con ++ read_args + infix_stmts -- a %% b, or a `T` b = [read_a1] - ++ (if isSym con_str - then [bindLex (symbol_pat con_str)] - else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]) + ++ read_infix_con ++ [read_a2] record_stmts -- T { f1 = a, f2 = b } - = [bindLex (ident_pat (wrapOpParens con_str)), - read_punc "{"] + = read_prefix_con + ++ [read_punc "{"] ++ concat (intersperse [read_punc ","] field_stmts) ++ [read_punc "}"] @@ -906,9 +902,8 @@ gen_Read_binds get_fixity tycon data_con_str con = occNameString (getOccName con) read_punc c = bindLex (punc_pat c) - read_arg a ty - | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty) - | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) + read_arg a ty = ASSERT( not (isUnLiftedType ty) ) + noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) read_field lbl a = read_lbl lbl ++ [read_punc "=", @@ -960,17 +955,16 @@ Example -- the most tightly-binding operator \begin{code} -gen_Show_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -gen_Show_binds get_fixity tycon +gen_Show_binds get_fixity loc tycon = (listToBag [shows_prec, show_list], []) where - tycon_loc = getSrcSpan tycon ----------------------------------------------------------------------- - show_list = mkVarBind tycon_loc showList_RDR + show_list = mkVarBind loc showList_RDR (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) ----------------------------------------------------------------------- - shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) + shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) where pats_etc data_con | nullary_con = -- skip the showParen junk... @@ -1045,9 +1039,10 @@ wrapOpBackquotes s | isSym s = s | otherwise = '`' : s ++ "`" isSym :: String -> Bool -isSym "" = False -isSym (c:cs) = startsVarSym c || startsConSym c +isSym "" = False +isSym (c : _) = startsVarSym c || startsConSym c +mk_showString_app :: String -> LHsExpr RdrName mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) \end{code} @@ -1090,16 +1085,15 @@ we generate We are passed the Typeable2 class as well as T \begin{code} -gen_Typeable_binds :: TyCon -> LHsBinds RdrName -gen_Typeable_binds tycon +gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName +gen_Typeable_binds loc tycon = unitBag $ - mk_easy_FunBind tycon_loc + mk_easy_FunBind loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function [nlWildPat] (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) where - tycon_loc = getSrcSpan tycon - tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) + tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) mk_typeOf_RDR :: TyCon -> RdrName -- Use the arity of the TyCon to make the right typeOfn function @@ -1143,24 +1137,27 @@ we generate dataTypeOf _ = $dT + dataCast1 = gcast1 -- If T :: * -> * + dataCast2 = gcast2 -- if T :: * -> * -> * + + \begin{code} -gen_Data_binds :: FixityEnv +gen_Data_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, -- The method bindings DerivAuxBinds) -- Auxiliary bindings -gen_Data_binds fix_env tycon - = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind], +gen_Data_binds loc tycon + = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] + `unionBags` gcast_binds, -- Auxiliary definitions: the data type and constructors - DerivAuxBind datatype_bind : map mk_con_bind data_cons) + MkTyCon tycon : map MkDataCon data_cons) where - tycon_loc = getSrcSpan tycon - tycon_name = tyConName tycon data_cons = tyConDataCons tycon n_cons = length data_cons one_constr = n_cons == 1 ------------ gfoldl - gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons) + gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons) gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed) where @@ -1170,7 +1167,7 @@ gen_Data_binds fix_env tycon mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) ------------ gunfold - gunfold_bind = mk_FunBind tycon_loc + gunfold_bind = mk_FunBind loc gunfold_RDR [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], gunfold_rhs)] @@ -1193,61 +1190,370 @@ gen_Data_binds fix_env tycon tag = dataConTag dc ------------ toConstr - toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons) + toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons) to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc)) ------------ dataTypeOf dataTypeOf_bind = mk_easy_FunBind - tycon_loc + loc dataTypeOf_RDR [nlWildPat] - (nlHsVar data_type_name) - - ------------ $dT - - data_type_name = mkDerivedRdrName tycon_name mkDataTOcc - datatype_bind = mkVarBind - tycon_loc - data_type_name - ( nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) - `nlHsApp` nlList constrs - ) - constrs = [nlHsVar (mk_constr_name con) | con <- data_cons] - - - ------------ $cT1 etc - mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc - mk_con_bind dc = DerivAuxBind $ - mkVarBind - tycon_loc - (mk_constr_name dc) - (nlHsApps mkConstr_RDR (constr_args dc)) - constr_args dc = - [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag - nlHsVar data_type_name, -- DataType - nlHsLit (mkHsString (occNameString dc_occ)), -- String name - nlList labels, -- Field labels - nlHsVar fixity] -- Fixity - where - labels = map (nlHsLit . mkHsString . getOccString) - (dataConFieldLabels dc) - dc_occ = getOccName dc - is_infix = isDataSymOcc dc_occ - fixity | is_infix = infix_RDR - | otherwise = prefix_RDR - -gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl") -gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold") -toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf") -mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr") -mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType") -conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex") -prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix") -infix_RDR = dataQual_RDR gENERICS FSLIT("Infix") + (nlHsVar (mk_data_type_name tycon)) + + ------------ gcast1/2 + tycon_kind = tyConKind tycon + gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR + | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR + | otherwise = emptyBag + mk_gcast dataCast_RDR gcast_RDR + = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR] + (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) + + +kind1, kind2 :: Kind +kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind +kind2 = liftedTypeKind `mkArrowKind` kind1 + +gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, + mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, + dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName +gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") +gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") +toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") +dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") +dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") +dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") +gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") +gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") +mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") +mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") +conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") +prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") +infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") \end{code} + + +%************************************************************************ +%* * + Functor instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + +%* * +%************************************************************************ + +For the data type: + + data T a = T1 Int a | T2 (T a) + +We generate the instance: + + instance Functor T where + fmap f (T1 b1 a) = T1 b1 (f a) + fmap f (T2 ta) = T2 (fmap f ta) + +Notice that we don't simply apply 'fmap' to the constructor arguments. +Rather + - Do nothing to an argument whose type doesn't mention 'a' + - Apply 'f' to an argument of type 'a' + - Apply 'fmap f' to other arguments +That's why we have to recurse deeply into the constructor argument types, +rather than just one level, as we typically do. + +What about types with more than one type parameter? In general, we only +derive Functor for the last position: + + data S a b = S1 [b] | S2 (a, T a b) + instance Functor (S a) where + fmap f (S1 bs) = S1 (fmap f bs) + fmap f (S2 (p,q)) = S2 (a, fmap f q) + +However, we have special cases for + - tuples + - functions + +More formally, we write the derivation of fmap code over type variable +'a for type 'b as ($fmap 'a 'b). In this general notation the derived +instance for T is: + + instance Functor T where + fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) + fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) + + $(fmap 'a 'b) x = x -- when b does not contain a + $(fmap 'a 'a) x = f x + $(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2) + $(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2 + $(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b)) + +For functions, the type parameter 'a can occur in a contravariant position, +which means we need to derive a function like: + + cofmap :: (a -> b) -> (f b -> f a) + +This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case: + + $(cofmap 'a 'b) x = x -- when b does not contain a + $(cofmap 'a 'a) x = error "type variable in contravariant position" + $(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) + $(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x + $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2 + $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b)) + +\begin{code} +gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Functor_binds loc tycon + = (unitBag fmap_bind, []) + where + data_cons = tyConDataCons tycon + + fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons) + fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs + where + parts = foldDataConArgs ft_fmap con + + ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)) + -- Tricky higher order type; I can't say I fully understand this code :-( + ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x + , ft_var = \x -> return (nlHsApp f_Expr x) -- fmap f x = f x + , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b)) + -- fmap f x = \b -> h (x (g b)) + , ft_tup = mkSimpleTupleCase match_for_con -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) + , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- fmap f x = fmap g x + return $ nlHsApps fmap_RDR [gg,x] + , ft_forall = \_ g x -> g x + , ft_bad_app = panic "in other argument" + , ft_co_var = panic "contravariant" } + + match_for_con = mkSimpleConMatch $ + \con_name xsM -> do xs <- sequence xsM + return (nlHsApps con_name xs) -- Con (g1 v1) (g2 v2) .. +\end{code} + +Utility functions related to Functor deriving. + +Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. +This function works like a fold: it makes a value of type 'a' in a bottom up way. + +\begin{code} +-- Generic traversal for Functor deriving +data FFoldType a -- Describes how to fold over a Type in a functor like way + = FT { ft_triv :: a -- Does not contain variable + , ft_var :: a -- The variable itself + , ft_co_var :: a -- The variable itself, contravariantly + , ft_fun :: a -> a -> a -- Function type + , ft_tup :: Boxity -> [a] -> a -- Tuple type + , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument + , ft_bad_app :: a -- Type app, variable other than in last argument + , ft_forall :: TcTyVar -> a -> a -- Forall type + } + +functorLikeTraverse :: TyVar -- ^ Variable to look for + -> FFoldType a -- ^ How to fold + -> Type -- ^ Type to process + -> a +functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar + , ft_co_var = caseCoVar, ft_fun = caseFun + , ft_tup = caseTuple, ft_ty_app = caseTyApp + , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) + ty + = fst (go False ty) + where -- go returns (result of type a, does type contain var) + go co ty | Just ty' <- coreView ty = go co ty' + go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) + go co (FunTy (PredTy _) b) = go co b + go co (FunTy x y) | xc || yc = (caseFun xr yr,True) + where (xr,xc) = go (not co) x + (yr,yc) = go co y + go co (AppTy x y) | xc = (caseWrongArg, True) + | yc = (caseTyApp x yr, True) + where (_, xc) = go co x + (yr,yc) = go co y + go co ty@(TyConApp con args) + | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True) + | null args = (caseTrivial,False) -- T + | or (init xcs) = (caseWrongArg,True) -- T (..var..) ty + | last xcs = -- T (..no var..) ty + (caseTyApp (fst (splitAppTy ty)) (last xrs),True) + where (xrs,xcs) = unzip (map (go co) args) + go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True) + where (xr,xc) = go co x + go _ _ = (caseTrivial,False) + +-- Return all syntactic subterms of ty that contain var somewhere +-- These are the things that should appear in instance constraints +deepSubtypesContaining :: TyVar -> Type -> [TcType] +deepSubtypesContaining tv + = functorLikeTraverse tv + (FT { ft_triv = [] + , ft_var = [] + , ft_fun = (++), ft_tup = \_ xs -> concat xs + , ft_ty_app = (:) + , ft_bad_app = panic "in other argument" + , ft_co_var = panic "contravariant" + , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs }) + + +foldDataConArgs :: FFoldType a -> DataCon -> [a] +-- Fold over the arguments of the datacon +foldDataConArgs ft con + = map (functorLikeTraverse tv ft) (dataConOrigArgTys con) + where + tv = last (dataConUnivTyVars con) + -- Argument to derive for, 'a in the above description + -- The validity checks have ensured that con is + -- a vanilla data constructor + +-- Make a HsLam using a fresh variable from a State monad +mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id) +-- (mkSimpleLam fn) returns (\x. fn(x)) +mkSimpleLam lam = do + (n:names) <- get + put names + body <- lam (nlHsVar n) + return (mkHsLam [nlVarPat n] body) + +mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id) +mkSimpleLam2 lam = do + (n1:n2:names) <- get + put names + body <- lam (nlHsVar n1) (nlHsVar n2) + return (mkHsLam [nlVarPat n1,nlVarPat n2] body) + +-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" +mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName) +mkSimpleConMatch fold extra_pats con insides = do + let con_name = getRdrName con + let vars_needed = takeList insides as_RDRs + let pat = nlConVarPat con_name vars_needed + rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed)) + return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds + +-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" +mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)) + -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName) +mkSimpleTupleCase match_for_con boxity insides x = do + let con = tupleCon boxity (length insides) + match <- match_for_con [] con insides + return $ nlHsCase x [match] +\end{code} + + +%************************************************************************ +%* * + Foldable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + +%* * +%************************************************************************ + +Deriving Foldable instances works the same way as Functor instances, +only Foldable instances are not possible for function types at all. +Here the derived instance for the type T above is: + + instance Foldable T where + foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) ) + +The cases are: + + $(foldr 'a 'b) x z = z -- when b does not contain a + $(foldr 'a 'a) x z = f x z + $(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) + $(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2 + +Note that the arguments to the real foldr function are the wrong way around, +since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). + +\begin{code} +gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Foldable_binds loc tycon + = (unitBag foldr_bind, []) + where + data_cons = tyConDataCons tycon + + foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons) + foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs + where + parts = foldDataConArgs ft_foldr con + + ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)) + ft_foldr = FT { ft_triv = \_ z -> return z -- foldr f z x = z + , ft_var = \x z -> return (nlHsApps f_RDR [x,z]) -- foldr f z x = f x z + , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x + , ft_ty_app = \_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x + return $ nlHsApps foldable_foldr_RDR [gg,z,x] + , ft_forall = \_ g x z -> g x z + , ft_co_var = panic "covariant" + , ft_fun = panic "function" + , ft_bad_app = panic "in other argument" } + + match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z)) +\end{code} + + +%************************************************************************ +%* * + Traversable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html +%* * +%************************************************************************ + +Again, Traversable is much like Functor and Foldable. + +The cases are: + + $(traverse 'a 'b) x = pure x -- when b does not contain a + $(traverse 'a 'a) x = f x + $(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2 + $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2 + +Note that the generated code is not as efficient as it could be. For instance: + + data T a = T Int a deriving Traversable + +gives the function: traverse f (T x y) = T <$> pure x <*> f y +instead of: traverse f (T x y) = T x <$> f y + +\begin{code} +gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Traversable_binds loc tycon + = (unitBag traverse_bind, []) + where + data_cons = tyConDataCons tycon + + traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons) + traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs + where + parts = foldDataConArgs ft_trav con + + + ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)) + ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x]) -- traverse f x = pure x + , ft_var = \x -> return (nlHsApps f_RDR [x]) -- travese f x = f x + , ft_tup = mkSimpleTupleCase match_for_con -- travese f x z = case x of (a1,a2,..) -> + -- (,,) <$> g1 a1 <*> g2 a2 <*> .. + , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x + return $ nlHsApps traverse_RDR [gg,x] + , ft_forall = \_ g x -> g x + , ft_co_var = panic "covariant" + , ft_fun = panic "function" + , ft_bad_app = panic "in other argument" } + + match_for_con = mkSimpleConMatch $ + \con_name xsM -> do xs <- sequence xsM + return (mkApCon (nlHsVar con_name) xs) + + -- ((Con <$> x1) <*> x2) <*> .. + mkApCon con [] = nlHsApps pure_RDR [con] + mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs + where appAp x y = nlHsApps ap_RDR [x,y] +\end{code} + + + %************************************************************************ %* * \subsection{Generating extra binds (@con2tag@ and @tag2con@)} @@ -1266,21 +1572,16 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. \begin{code} -genAuxBind :: DerivAuxBind -> LHsBind RdrName - -genAuxBind (DerivAuxBind bind) - = bind - -genAuxBind (GenCon2Tag tycon) +genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName +genAuxBind loc (GenCon2Tag tycon) | lots_of_constructors - = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)] + = mk_FunBind loc rdr_name [([], get_tag_rhs)] | otherwise - = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon)) + = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon)) where rdr_name = con2tag_RDR tycon - tycon_loc = getSrcSpan tycon tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon) -- We can't use gerRdrName because that makes an Exact RdrName @@ -1289,7 +1590,7 @@ genAuxBind (GenCon2Tag tycon) -- Give a signature to the bound variable, so -- that the case expression generated by getTag is -- monomorphic. In the push-enter model we get better code. - get_tag_rhs = noLoc $ ExprWithTySig + get_tag_rhs = L loc $ ExprWithTySig (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR) (nlHsApp (nlHsVar getTag_RDR) a_Expr))) (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty)) @@ -1306,21 +1607,53 @@ genAuxBind (GenCon2Tag tycon) mk_stuff con = ([nlWildConPat con], nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) -genAuxBind (GenTag2Con tycon) - = mk_FunBind (getSrcSpan tycon) rdr_name +genAuxBind loc (GenTag2Con tycon) + = mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr) (nlHsTyVar (getRdrName tycon))))] where rdr_name = tag2con_RDR tycon -genAuxBind (GenMaxTag tycon) - = mkVarBind (getSrcSpan tycon) rdr_name +genAuxBind loc (GenMaxTag tycon) + = mkVarBind loc 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) + +genAuxBind loc (MkTyCon tycon) -- $dT + = mkVarBind loc (mk_data_type_name tycon) + ( nlHsVar mkDataType_RDR + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) + `nlHsApp` nlList constrs ) + where + constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] + +genAuxBind loc (MkDataCon dc) -- $cT1 etc + = mkVarBind loc (mk_constr_name dc) + (nlHsApps mkConstr_RDR constr_args) + where + constr_args + = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag + nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType + nlHsLit (mkHsString (occNameString dc_occ)), -- String name + nlList labels, -- Field labels + nlHsVar fixity] -- Fixity + + labels = map (nlHsLit . mkHsString . getOccString) + (dataConFieldLabels dc) + dc_occ = getOccName dc + is_infix = isDataSymOcc dc_occ + fixity | is_infix = infix_RDR + | otherwise = prefix_RDR + +mk_data_type_name :: TyCon -> RdrName -- "$tT" +mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc + +mk_constr_name :: DataCon -> RdrName -- "$cC" +mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc \end{code} %************************************************************************ @@ -1344,6 +1677,7 @@ careful_compare_Case :: -- checks for primitive types... -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b -- Was: compare_gen_Case cmp_eq_RDR @@ -1384,7 +1718,7 @@ assoc_ty_id :: String -- The class involved -> [(Type,a)] -- The table -> Type -- The type -> a -- The result of the lookup -assoc_ty_id cls_str tycon tbl ty +assoc_ty_id cls_str _ tbl ty | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+> text "for primitive type" <+> ppr ty) | otherwise = head res @@ -1411,6 +1745,7 @@ lt_op_tbl = ,(doublePrimTy, DoubleLtOp) ] +box_con_tbl :: [(Type, RdrName)] box_con_tbl = [(charPrimTy, getRdrName charDataCon) ,(intPrimTy, getRdrName intDataCon) @@ -1437,7 +1772,7 @@ eq_Expr tycon ty a b = genOpApp a eq_op b \begin{code} untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName -untag_Expr tycon [] expr = expr +untag_Expr _ [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)] @@ -1476,15 +1811,18 @@ nested_compose_Expr (e:es) -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen! +impossible_Expr :: LHsExpr RdrName impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv")) -- illegal_Expr is used when signalling error conditions in the RHS of a derived -- method. It is currently only used by Enum.{succ,pred} +illegal_Expr :: String -> String -> String -> LHsExpr RdrName illegal_Expr meth tp msg = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you -- to include the value of a_RDR in the error string. +illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName illegal_toEnum_tag tp maxtag = nlHsApp (nlHsVar error_RDR) (nlHsApp (nlHsApp (nlHsVar append_RDR) @@ -1502,68 +1840,84 @@ illegal_toEnum_tag tp maxtag = (nlHsVar maxtag)) (nlHsLit (mkHsString ")")))))) +parenify :: LHsExpr RdrName -> LHsExpr RdrName parenify e@(L _ (HsVar _)) = e parenify e = mkHsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. +genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) \end{code} \begin{code} -a_RDR = mkVarUnqual FSLIT("a") -b_RDR = mkVarUnqual FSLIT("b") -c_RDR = mkVarUnqual FSLIT("c") -d_RDR = mkVarUnqual FSLIT("d") -k_RDR = mkVarUnqual FSLIT("k") -z_RDR = mkVarUnqual FSLIT("z") -ah_RDR = mkVarUnqual FSLIT("a#") -bh_RDR = mkVarUnqual FSLIT("b#") -ch_RDR = mkVarUnqual FSLIT("c#") -dh_RDR = mkVarUnqual FSLIT("d#") -cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq") - +a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR, + cmp_eq_RDR :: RdrName +a_RDR = mkVarUnqual (fsLit "a") +b_RDR = mkVarUnqual (fsLit "b") +c_RDR = mkVarUnqual (fsLit "c") +d_RDR = mkVarUnqual (fsLit "d") +f_RDR = mkVarUnqual (fsLit "f") +k_RDR = mkVarUnqual (fsLit "k") +z_RDR = mkVarUnqual (fsLit "z") +ah_RDR = mkVarUnqual (fsLit "a#") +bh_RDR = mkVarUnqual (fsLit "b#") +ch_RDR = mkVarUnqual (fsLit "c#") +dh_RDR = mkVarUnqual (fsLit "d#") +cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq") + +as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] +a_Expr, b_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, + false_Expr, true_Expr :: LHsExpr RdrName a_Expr = nlHsVar a_RDR b_Expr = nlHsVar b_RDR c_Expr = nlHsVar c_RDR +f_Expr = nlHsVar f_RDR +z_Expr = nlHsVar z_RDR ltTag_Expr = nlHsVar ltTag_RDR eqTag_Expr = nlHsVar eqTag_RDR gtTag_Expr = nlHsVar gtTag_RDR false_Expr = nlHsVar false_RDR true_Expr = nlHsVar true_RDR +a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName a_Pat = nlVarPat a_RDR b_Pat = nlVarPat b_RDR c_Pat = nlVarPat c_RDR d_Pat = nlVarPat d_RDR +f_Pat = nlVarPat f_RDR k_Pat = nlVarPat k_RDR z_Pat = nlVarPat z_RDR -con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName -- Generates Orig s RdrName, for the binding positions -con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_" -tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_" -maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_" - -mk_tc_deriv_name tycon str - = mkDerivedRdrName tc_name mk_occ - where - tc_name = tyConName tycon - mk_occ tc_occ = mkVarOccFS (mkFastString new_str) - where - new_str = str ++ occNameString tc_occ ++ "#" +con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc +tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc +maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc + +mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName +mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun + +mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName +mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent)) +-- Was: mkDerivedRdrName name occ_fun, which made an original name +-- But: (a) that does not work well for standalone-deriving +-- (b) an unqualified name is just fine, provided it can't clash with user code \end{code} s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports PrelNames, so PrelNames can't import PrimOp. \begin{code} +primOpRdrName :: PrimOp -> RdrName primOpRdrName op = getRdrName (primOpId op) +minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR, + tagToEnum_RDR :: RdrName minusInt_RDR = primOpRdrName IntSubOp eqInt_RDR = primOpRdrName IntEqOp ltInt_RDR = primOpRdrName IntLtOp @@ -1571,5 +1925,6 @@ geInt_RDR = primOpRdrName IntGeOp leInt_RDR = primOpRdrName IntLeOp tagToEnum_RDR = primOpRdrName TagToEnumOp +error_RDR :: RdrName error_RDR = getRdrName eRROR_ID \end{code}