read_nullary_cons
= case nullary_cons of
[] -> []
- [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
- (result_expr con [])]
+ [con] -> [nlHsDo DoExpr [bindLex (match_con con)] (result_expr con [])]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
-
+ -- NB For operators the parens around (:=:) are matched by the
+ -- enclosing "parens" call, so here we must match the naked
+ -- data_con_str con
+
+ match_con con | isSym con_str = symbol_pat con_str
+ | otherwise = ident_pat con_str
+ where
+ con_str = data_con_str con
+ -- For nullary constructors we must match Ident s for normal constrs
+ -- and Symbol s for operators
+
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
| is_record = mk_parser record_prec record_stmts body
pats_etc data_con
| nullary_con = -- skip the showParen junk...
ASSERT(null bs_needed)
- ([nlWildPat, con_pat], mk_showString_app con_str)
+ ([nlWildPat, con_pat], mk_showString_app op_con_str)
| otherwise =
([a_Pat, con_pat],
showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
= (unitBag fmap_bind, [])
where
data_cons = tyConDataCons tycon
-
- fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
+ fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) eqns
+
fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
where
parts = foldDataConArgs ft_fmap con
+ -- Catch-all eqn looks like fmap _ _ = error "impossible"
+ -- It's needed if there no data cons at all
+ eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
+ (error_Expr "Void fmap")]
+ | otherwise = map fmap_eqn data_cons
+
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
where
data_cons = tyConDataCons tycon
- foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons)
+ foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) eqns
+ eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat, nlWildPat]
+ (error_Expr "Void foldr")]
+ | otherwise = 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
where
data_cons = tyConDataCons tycon
- traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
+ traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) eqns
+ eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
+ (error_Expr "Void traverse")]
+ | otherwise = map traverse_eqn data_cons
traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
where
parts = foldDataConArgs ft_trav con
-- 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"))
+error_Expr :: String -> LHsExpr RdrName
+error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
-- illegal_Expr is used when signalling error conditions in the RHS of a derived
-- method. It is currently only used by Enum.{succ,pred}