+ | nullary_con = -- skip the showParen junk...
+ ASSERT(null bs_needed)
+ ([wildPat, con_pat], mk_showString_app con_str)
+ | otherwise =
+ ([a_Pat, con_pat],
+ showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one))))
+ (HsPar (nested_compose_Expr show_thingies)))
+ where
+ data_con_RDR = getRdrName data_con
+ con_arity = dataConSourceArity data_con
+ bs_needed = take con_arity bs_RDRs
+ arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
+ con_pat = mkConPat data_con_RDR bs_needed
+ nullary_con = con_arity == 0
+ labels = dataConFieldLabels data_con
+ lab_fields = length labels
+ record_syntax = lab_fields > 0
+
+ dc_nm = getName data_con
+ dc_occ_nm = getOccName data_con
+ con_str = occNameUserString dc_occ_nm
+
+ show_thingies
+ | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
+ | record_syntax = mk_showString_app (con_str ++ " {") :
+ show_record_args ++ [mk_showString_app "}"]
+ | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
+
+ show_label l = mk_showString_app (the_name ++ " = ")
+ -- 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
+
+ show_args = zipWith show_arg bs_needed arg_tys
+ (show_arg1:show_arg2:_) = show_args
+ show_prefix_args = intersperse (HsVar showSpace_RDR) show_args
+
+ -- Assumption for record syntax: no of fields == no of labelled fields
+ -- (and in same order)
+ show_record_args = concat $
+ intersperse [mk_showString_app ", "] $
+ [ [show_label lbl, arg]
+ | (lbl,arg) <- zipEqual "gen_Show_binds"
+ labels show_args ]
+
+ -- Generates (showsPrec p x) for argument x, but it also boxes
+ -- the argument first if necessary. Note that this prints unboxed
+ -- things without any '#' decorations; could change that if need be
+ show_arg b arg_ty = mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec),
+ box_if_necy "Show" tycon (HsVar b) arg_ty]
+
+ -- Fixity stuff
+ is_infix = isDataSymOcc dc_occ_nm
+ 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
+
+mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str))
+\end{code}
+
+\begin{code}
+getPrec :: Bool -> FixityEnv -> Name -> Integer
+getPrec is_infix get_fixity nm
+ | not is_infix = appPrecedence
+ | otherwise = getPrecedence get_fixity nm
+
+appPrecedence :: Integer
+appPrecedence = fromIntegral maxPrecedence + 1
+ -- One more than the precedence of the most
+ -- tightly-binding operator
+
+getPrecedence :: FixityEnv -> Name -> Integer
+getPrecedence get_fixity nm
+ = case lookupFixity get_fixity nm of
+ Fixity x _ -> fromIntegral x
+
+isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
+isLRAssoc get_fixity nm =
+ case lookupFixity get_fixity nm of
+ Fixity _ InfixN -> (False, False)
+ Fixity _ InfixR -> (False, True)
+ Fixity _ InfixL -> (True, False)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Typeable}
+%* *
+%************************************************************************
+
+From the data type
+
+ data T a b = ....
+
+we generate
+
+ instance (Typeable a, Typeable b) => Typeable (T a b) where
+ typeOf _ = mkTypeRep (mkTyConRep "T")
+ [typeOf (undefined::a),
+ typeOf (undefined::b)]
+
+Notice the use of lexically scoped type variables.
+
+\begin{code}
+gen_Typeable_binds :: TyCon -> RdrNameMonoBinds
+gen_Typeable_binds tycon
+ = mk_easy_FunMonoBind tycon_loc typeOf_RDR [wildPat] []
+ (mkHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
+ where
+ tycon_loc = getSrcLoc tycon
+ tyvars = tyConTyVars tycon
+ tycon_rep = HsVar mkTyConRep_RDR `HsApp` HsLit (mkHsString (showSDoc (ppr tycon)))
+ arg_reps = ExplicitList placeHolderType (map mk tyvars)
+ mk tyvar = HsApp (HsVar typeOf_RDR)
+ (ExprWithTySig (HsVar undefined_RDR)
+ (HsTyVar (getRdrName tyvar)))
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Data}
+%* *
+%************************************************************************
+
+From the data type
+
+ data T a b = T1 a b | T2
+
+we generate
+
+ instance (Data a, Data b) => Data (T a b) where
+ gfoldl k z (T1 a b) = z T `k` a `k` b
+ gfoldl k z T2 = z T2
+ -- ToDo: add gmapT,Q,M, gfoldr
+
+ gunfold k z (Constr "T1") = k (k (z T1))
+ gunfold k z (Constr "T2") = z T2
+
+ conOf (T1 _ _) = Constr "T1"
+ conOf T2 = Constr "T2"
+
+ consOf _ = [Constr "T1", Constr "T2"]
+
+ToDo: generate auxiliary bindings for the Constrs?
+
+\begin{code}
+gen_Data_binds :: TyCon -> RdrNameMonoBinds
+gen_Data_binds tycon
+ = andMonoBindList [gfoldl_bind, gunfold_bind, conOf_bind, consOf_bind]
+ where
+ tycon_loc = getSrcLoc tycon
+ data_cons = tyConDataCons tycon
+
+ ------------ gfoldl
+ gfoldl_bind = mk_FunMonoBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
+ gfoldl_eqn con = ([VarPat k_RDR, VarPat z_RDR, mkConPat con_name as_needed],
+ foldl mk_k_app (HsVar z_RDR `HsApp` HsVar con_name) as_needed)
+ where
+ con_name :: RdrName
+ con_name = getRdrName con
+ as_needed = take (dataConSourceArity con) as_RDRs
+ mk_k_app e v = HsPar (mkHsOpApp e k_RDR (HsVar v))
+
+ ------------ gunfold
+ gunfold_bind = mk_FunMonoBind tycon_loc gunfold_RDR (map gunfold_eqn data_cons)
+ gunfold_eqn con = ([VarPat k_RDR, VarPat z_RDR,
+ ConPatIn constr_RDR (PrefixCon [LitPat (mk_constr_string con)])],
+ apN (dataConSourceArity con)
+ (\e -> HsVar k_RDR `HsApp` e)
+ (z_Expr `HsApp` HsVar (getRdrName con)))
+ mk_constr_string con = mkHsString (occNameUserString (getOccName con))
+
+ ------------ conOf
+ conOf_bind = mk_FunMonoBind tycon_loc conOf_RDR (map conOf_eqn data_cons)
+ conOf_eqn con = ([mkWildConPat con], mk_constr con)
+
+ ------------ consOf
+ consOf_bind = mk_easy_FunMonoBind tycon_loc consOf_RDR [wildPat] []
+ (ExplicitList placeHolderType (map mk_constr data_cons))
+ mk_constr con = HsVar constr_RDR `HsApp` (HsLit (mk_constr_string con))
+
+
+apN :: Int -> (a -> a) -> a -> a
+apN 0 k z = z
+apN n k z = apN (n-1) k (k z)