- = let
- data_con_RDR = qual_orig_name data_con
- con_arity = argFieldCount data_con
- bs_needed = take con_arity bs_RDRs
- con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
- nullary_con = con_arity == 0
-
- show_con
- = let nm = occNameString (getOccName data_con)
- space_maybe = if nullary_con then _NIL_ else SLIT(" ")
- in
- HsApp (HsVar showString_RDR) (HsLit (HsString (nm _APPEND_ space_maybe)))
-
- show_thingies = show_con : (spacified real_show_thingies)
-
- real_show_thingies
- = [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
- | b <- bs_needed ]
- in
- if nullary_con then -- skip the showParen junk...
- ASSERT(null bs_needed)
- ([a_Pat, con_pat], show_con)
- else
- ([a_Pat, con_pat],
- showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
- (HsPar (nested_compose_Expr show_thingies)))
- where
- spacified [] = []
- spacified [x] = [x]
- spacified (x:xs) = (x : (HsVar showSpace_RDR) : spacified xs)
+ | 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
+ 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 = [ mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec), HsVar b]
+ | b <- bs_needed ]
+ (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 ]
+
+ -- 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)