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}
gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Ord_binds tycon
+ | Just (con, prim_tc) <- primWrapperType_maybe tycon
+ = gen_PrimOrd_binds con prim_tc
+
+ | otherwise
= (unitBag compare, aux_binds)
-- `AndMonoBinds` compare
-- The default declaration in PrelBase handles this
in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
+\end{code}
+Note [Comparision of primitive types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The general plan does not work well for data types like
+ data T = MkT Int# deriving( Ord )
+The general plan defines the 'compare' method, gets (<) etc from it. But
+that means we get silly code like:
+ instance Ord T where
+ (>) (I# x) (I# y) = case <# x y of
+ True -> False
+ False -> case ==# x y of
+ True -> False
+ False -> True
+We would prefer to use the (>#) primop. See also Trac #2130
+
+
+\begin{code}
+gen_PrimOrd_binds :: DataCon -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+-- See Note [Comparison of primitive types]
+gen_PrimOrd_binds data_con prim_tc
+ = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op,
+ mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
+ where
+ mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR
+ [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
+ con_RDR = getRdrName data_con
+ apat = nlConVarPat con_RDR [a_RDR]
+ bpat = nlConVarPat con_RDR [b_RDR]
+
+ (lt_op, le_op, ge_op, gt_op)
+ | prim_tc == charPrimTyCon = (CharLtOp, CharLeOp, CharGeOp, CharGtOp)
+ | prim_tc == intPrimTyCon = (IntLtOp, IntLeOp, IntGeOp, IntGtOp)
+ | prim_tc == wordPrimTyCon = (WordLtOp, WordLeOp, WordGeOp, WordGtOp)
+ | prim_tc == addrPrimTyCon = (AddrLtOp, AddrLeOp, AddrGeOp, AddrGtOp)
+ | prim_tc == floatPrimTyCon = (FloatLtOp, FloatLeOp, FloatGeOp, FloatGtOp)
+ | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
+ | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
+
+
+primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
+-- True of data types that are wrappers around prmitive types
+-- data T = MkT Word#
+-- For these we want to generate all the (<), (<=) etc operations individually
+primWrapperType_maybe tc
+ | [con] <- tyConDataCons tc
+ , [ty] <- dataConOrigArgTys con
+ , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
+ , isPrimTyCon prim_tc
+ = Just (con, prim_tc)
+ | otherwise
+ = Nothing
\end{code}
%************************************************************************
= mk_easy_FunBind tycon_loc unsafeIndex_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed]
- (mk_index (zip3 as_needed bs_needed cs_needed))
+ -- We need to reverse the order we consider the components in
+ -- so that
+ -- range (l,u) !! index (l,u) i == i -- when i is in range
+ -- (from http://haskell.org/onlinereport/ix.html) holds.
+ (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
where
-- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
mk_index [] = nlHsIntLit 0
| 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}
getPrecedence :: FixityEnv -> Name -> Integer
getPrecedence get_fixity nm
= case lookupFixity get_fixity nm of
- Fixity x _ -> fromIntegral x
+ Fixity x _assoc -> fromIntegral x
+ -- NB: the Report says that associativity is not taken
+ -- into account for either Read or Show; hence we
+ -- ignore associativity here
\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
| not (isUnLiftedType ty)
= compare_gen_Case eq a b
| otherwise -- We have to do something special for primitive things...
- = nlHsIf (genOpApp a relevant_eq_op b)
- eq
- (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
+ = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter
+ ltTag_Expr -- is true less often, so putting it first would
+ -- mean more tests (dynamically)
+ (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
where
relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
-> [(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}
projects / ghc-hetmet.git / blobdiff