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,
| 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
+isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
+isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
+isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2
+isDupAux _ _ = False
\end{code}
| 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}
-> TyCon
-> (LHsBinds RdrName, -- The method bindings
DerivAuxBinds) -- Auxiliary bindings
-gen_Data_binds fix_env tycon
+gen_Data_binds _ tycon
= (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
-- Auxiliary definitions: the data type and constructors
DerivAuxBind datatype_bind : map mk_con_bind data_cons)
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")
+gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
+ mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_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")
+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}
%************************************************************************
-> 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
-> [(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
,(doublePrimTy, DoubleLtOp)
]
+box_con_tbl :: [(Type, RdrName)]
box_con_tbl =
[(charPrimTy, getRdrName charDataCon)
,(intPrimTy, getRdrName intDataCon)
\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)]
-- 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)
(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, 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")
+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, 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
false_Expr = nlHsVar false_RDR
true_Expr = nlHsVar true_RDR
+a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
a_Pat = nlVarPat a_RDR
b_Pat = nlVarPat b_RDR
c_Pat = nlVarPat c_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_"
+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 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 ++ "#"
+mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
+mk_tc_deriv_name tycon fun = mkDerivedRdrName (tyConName tycon) fun
\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
leInt_RDR = primOpRdrName IntLeOp
tagToEnum_RDR = primOpRdrName TagToEnumOp
+error_RDR :: RdrName
error_RDR = getRdrName eRROR_ID
\end{code}