1{- 2 % 3(c) The University of Glasgow 2006 4(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 5 6 7TcGenDeriv: Generating derived instance declarations 8 9This module is nominally ``subordinate'' to @TcDeriv@, which is the 10``official'' interface to deriving-related things. 11 12This is where we do all the grimy bindings' generation. 13-} 14 15{-# LANGUAGE CPP, ScopedTypeVariables #-} 16{-# LANGUAGE FlexibleContexts #-} 17{-# LANGUAGE TypeFamilies #-} 18 19module TcGenDeriv ( 20 BagDerivStuff, DerivStuff(..), 21 22 gen_Eq_binds, 23 gen_Ord_binds, 24 gen_Enum_binds, 25 gen_Bounded_binds, 26 gen_Ix_binds, 27 gen_Show_binds, 28 gen_Read_binds, 29 gen_Data_binds, 30 gen_Lift_binds, 31 gen_Newtype_binds, 32 mkCoerceClassMethEqn, 33 genAuxBinds, 34 ordOpTbl, boxConTbl, litConTbl, 35 mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr 36 ) where 37 38#include "HsVersions.h" 39 40import GhcPrelude 41 42import TcRnMonad 43import GHC.Hs 44import RdrName 45import BasicTypes 46import DataCon 47import Name 48import Fingerprint 49import Encoding 50 51import DynFlags 52import PrelInfo 53import FamInst 54import FamInstEnv 55import PrelNames 56import THNames 57import MkId ( coerceId ) 58import PrimOp 59import SrcLoc 60import TyCon 61import TcEnv 62import TcType 63import TcValidity ( checkValidCoAxBranch ) 64import CoAxiom ( coAxiomSingleBranch ) 65import TysPrim 66import TysWiredIn 67import Type 68import Class 69import VarSet 70import VarEnv 71import Util 72import Var 73import Outputable 74import Lexeme 75import FastString 76import Pair 77import Bag 78 79import Data.List ( find, partition, intersperse ) 80 81type BagDerivStuff = Bag DerivStuff 82 83data AuxBindSpec 84 = DerivCon2Tag TyCon -- The con2Tag for given TyCon 85 | DerivTag2Con TyCon -- ...ditto tag2Con 86 | DerivMaxTag TyCon -- ...and maxTag 87 deriving( Eq ) 88 -- All these generate ZERO-BASED tag operations 89 -- I.e first constructor has tag 0 90 91data DerivStuff -- Please add this auxiliary stuff 92 = DerivAuxBind AuxBindSpec 93 94 -- Generics and DeriveAnyClass 95 | DerivFamInst FamInst -- New type family instances 96 97 -- New top-level auxiliary bindings 98 | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB 99 100 101{- 102************************************************************************ 103* * 104 Eq instances 105* * 106************************************************************************ 107 108Here are the heuristics for the code we generate for @Eq@. Let's 109assume we have a data type with some (possibly zero) nullary data 110constructors and some ordinary, non-nullary ones (the rest, also 111possibly zero of them). Here's an example, with both \tr{N}ullary and 112\tr{O}rdinary data cons. 113 114 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... 115 116* For the ordinary constructors (if any), we emit clauses to do The 117 Usual Thing, e.g.,: 118 119 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2 120 (==) (O2 a1) (O2 a2) = a1 == a2 121 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 122 123 Note: if we're comparing unlifted things, e.g., if 'a1' and 124 'a2' are Float#s, then we have to generate 125 case (a1 `eqFloat#` a2) of r -> r 126 for that particular test. 127 128* If there are a lot of (more than ten) nullary constructors, we emit a 129 catch-all clause of the form: 130 131 (==) a b = case (con2tag_Foo a) of { a# -> 132 case (con2tag_Foo b) of { b# -> 133 case (a# ==# b#) of { 134 r -> r }}} 135 136 If con2tag gets inlined this leads to join point stuff, so 137 it's better to use regular pattern matching if there aren't too 138 many nullary constructors. "Ten" is arbitrary, of course 139 140* If there aren't any nullary constructors, we emit a simpler 141 catch-all: 142 143 (==) a b = False 144 145* For the @(/=)@ method, we normally just use the default method. 146 If the type is an enumeration type, we could/may/should? generate 147 special code that calls @con2tag_Foo@, much like for @(==)@ shown 148 above. 149 150We thought about doing this: If we're also deriving 'Ord' for this 151tycon, we generate: 152 instance ... Eq (Foo ...) where 153 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False} 154 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True } 155However, that requires that (Ord <whatever>) was put in the context 156for the instance decl, which it probably wasn't, so the decls 157produced don't get through the typechecker. 158-} 159 160gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) 161gen_Eq_binds loc tycon = do 162 dflags <- getDynFlags 163 return (method_binds dflags, aux_binds) 164 where 165 all_cons = tyConDataCons tycon 166 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons 167 168 -- If there are ten or more (arbitrary number) nullary constructors, 169 -- use the con2tag stuff. For small types it's better to use 170 -- ordinary pattern matching. 171 (tag_match_cons, pat_match_cons) 172 | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons) 173 | otherwise = ([], all_cons) 174 175 no_tag_match_cons = null tag_match_cons 176 177 fall_through_eqn dflags 178 | no_tag_match_cons -- All constructors have arguments 179 = case pat_match_cons of 180 [] -> [] -- No constructors; no fall-though case 181 [_] -> [] -- One constructor; no fall-though case 182 _ -> -- Two or more constructors; add fall-through of 183 -- (==) _ _ = False 184 [([nlWildPat, nlWildPat], false_Expr)] 185 186 | otherwise -- One or more tag_match cons; add fall-through of 187 -- extract tags compare for equality 188 = [([a_Pat, b_Pat], 189 untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] 190 (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] 191 192 aux_binds | no_tag_match_cons = emptyBag 193 | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon 194 195 method_binds dflags = unitBag (eq_bind dflags) 196 eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr) 197 (map pats_etc pat_match_cons 198 ++ fall_through_eqn dflags) 199 200 ------------------------------------------------------------------ 201 pats_etc data_con 202 = let 203 con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed 204 con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed 205 206 data_con_RDR = getRdrName data_con 207 con_arity = length tys_needed 208 as_needed = take con_arity as_RDRs 209 bs_needed = take con_arity bs_RDRs 210 tys_needed = dataConOrigArgTys data_con 211 in 212 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) 213 where 214 nested_eq_expr [] [] [] = true_Expr 215 nested_eq_expr tys as bs 216 = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) 217 -- Using 'foldr1' here ensures that the derived code is correctly 218 -- associated. See #10859. 219 where 220 nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) 221 222{- 223************************************************************************ 224* * 225 Ord instances 226* * 227************************************************************************ 228 229Note [Generating Ord instances] 230~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 231Suppose constructors are K1..Kn, and some are nullary. 232The general form we generate is: 233 234* Do case on first argument 235 case a of 236 K1 ... -> rhs_1 237 K2 ... -> rhs_2 238 ... 239 Kn ... -> rhs_n 240 _ -> nullary_rhs 241 242* To make rhs_i 243 If i = 1, 2, n-1, n, generate a single case. 244 rhs_2 case b of 245 K1 {} -> LT 246 K2 ... -> ...eq_rhs(K2)... 247 _ -> GT 248 249 Otherwise do a tag compare against the bigger range 250 (because this is the one most likely to succeed) 251 rhs_3 case tag b of tb -> 252 if 3 <# tg then GT 253 else case b of 254 K3 ... -> ...eq_rhs(K3).... 255 _ -> LT 256 257* To make eq_rhs(K), which knows that 258 a = K a1 .. av 259 b = K b1 .. bv 260 we just want to compare (a1,b1) then (a2,b2) etc. 261 Take care on the last field to tail-call into comparing av,bv 262 263* To make nullary_rhs generate this 264 case con2tag a of a# -> 265 case con2tag b of -> 266 a# `compare` b# 267 268Several special cases: 269 270* Two or fewer nullary constructors: don't generate nullary_rhs 271 272* Be careful about unlifted comparisons. When comparing unboxed 273 values we can't call the overloaded functions. 274 See function unliftedOrdOp 275 276Note [Game plan for deriving Ord] 277~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 278It's a bad idea to define only 'compare', and build the other binary 279comparisons on top of it; see #2130, #4019. Reason: we don't 280want to laboriously make a three-way comparison, only to extract a 281binary result, something like this: 282 (>) (I# x) (I# y) = case <# x y of 283 True -> False 284 False -> case ==# x y of 285 True -> False 286 False -> True 287 288This being said, we can get away with generating full code only for 289'compare' and '<' thus saving us generation of other three operators. 290Other operators can be cheaply expressed through '<': 291a <= b = not $ b < a 292a > b = b < a 293a >= b = not $ a < b 294 295So for sufficiently small types (few constructors, or all nullary) 296we generate all methods; for large ones we just use 'compare'. 297 298-} 299 300data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT 301 302------------ 303ordMethRdr :: OrdOp -> RdrName 304ordMethRdr op 305 = case op of 306 OrdCompare -> compare_RDR 307 OrdLT -> lt_RDR 308 OrdLE -> le_RDR 309 OrdGE -> ge_RDR 310 OrdGT -> gt_RDR 311 312------------ 313ltResult :: OrdOp -> LHsExpr GhcPs 314-- Knowing a<b, what is the result for a `op` b? 315ltResult OrdCompare = ltTag_Expr 316ltResult OrdLT = true_Expr 317ltResult OrdLE = true_Expr 318ltResult OrdGE = false_Expr 319ltResult OrdGT = false_Expr 320 321------------ 322eqResult :: OrdOp -> LHsExpr GhcPs 323-- Knowing a=b, what is the result for a `op` b? 324eqResult OrdCompare = eqTag_Expr 325eqResult OrdLT = false_Expr 326eqResult OrdLE = true_Expr 327eqResult OrdGE = true_Expr 328eqResult OrdGT = false_Expr 329 330------------ 331gtResult :: OrdOp -> LHsExpr GhcPs 332-- Knowing a>b, what is the result for a `op` b? 333gtResult OrdCompare = gtTag_Expr 334gtResult OrdLT = false_Expr 335gtResult OrdLE = false_Expr 336gtResult OrdGE = true_Expr 337gtResult OrdGT = true_Expr 338 339------------ 340gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) 341gen_Ord_binds loc tycon = do 342 dflags <- getDynFlags 343 return $ if null tycon_data_cons -- No data-cons => invoke bale-out case 344 then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) [] 345 , emptyBag) 346 else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags 347 , aux_binds) 348 where 349 aux_binds | single_con_type = emptyBag 350 | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon 351 352 -- Note [Game plan for deriving Ord] 353 other_ops dflags 354 | (last_tag - first_tag) <= 2 -- 1-3 constructors 355 || null non_nullary_cons -- Or it's an enumeration 356 = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE] 357 | otherwise 358 = emptyBag 359 360 negate_expr = nlHsApp (nlHsVar not_RDR) 361 lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $ 362 negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr) 363 gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $ 364 nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr 365 gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $ 366 negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) 367 368 get_tag con = dataConTag con - fIRST_TAG 369 -- We want *zero-based* tags, because that's what 370 -- con2Tag returns (generated by untag_Expr)! 371 372 tycon_data_cons = tyConDataCons tycon 373 single_con_type = isSingleton tycon_data_cons 374 (first_con : _) = tycon_data_cons 375 (last_con : _) = reverse tycon_data_cons 376 first_tag = get_tag first_con 377 last_tag = get_tag last_con 378 379 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons 380 381 382 mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs 383 -- Returns a binding op a b = ... compares a and b according to op .... 384 mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat] 385 (mkOrdOpRhs dflags op) 386 387 mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs 388 mkOrdOpRhs dflags op -- RHS for comparing 'a' and 'b' according to op 389 | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases 390 = nlHsCase (nlHsVar a_RDR) $ 391 map (mkOrdOpAlt dflags op) tycon_data_cons 392 -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... 393 -- C2 x -> case b of C2 x -> ....comopare x.... } 394 395 | null non_nullary_cons -- All nullary, so go straight to comparing tags 396 = mkTagCmp dflags op 397 398 | otherwise -- Mixed nullary and non-nullary 399 = nlHsCase (nlHsVar a_RDR) $ 400 (map (mkOrdOpAlt dflags op) non_nullary_cons 401 ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)]) 402 403 404 mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon 405 -> LMatch GhcPs (LHsExpr GhcPs) 406 -- Make the alternative (Ki a1 a2 .. av -> 407 mkOrdOpAlt dflags op data_con 408 = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) 409 (mkInnerRhs dflags op data_con) 410 where 411 as_needed = take (dataConSourceArity data_con) as_RDRs 412 data_con_RDR = getRdrName data_con 413 414 mkInnerRhs dflags op data_con 415 | single_con_type 416 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] 417 418 | tag == first_tag 419 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con 420 , mkHsCaseAlt nlWildPat (ltResult op) ] 421 | tag == last_tag 422 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con 423 , mkHsCaseAlt nlWildPat (gtResult op) ] 424 425 | tag == first_tag + 1 426 = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con) 427 (gtResult op) 428 , mkInnerEqAlt op data_con 429 , mkHsCaseAlt nlWildPat (ltResult op) ] 430 | tag == last_tag - 1 431 = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con) 432 (ltResult op) 433 , mkInnerEqAlt op data_con 434 , mkHsCaseAlt nlWildPat (gtResult op) ] 435 436 | tag > last_tag `div` 2 -- lower range is larger 437 = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ 438 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) 439 (gtResult op) $ -- Definitely GT 440 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con 441 , mkHsCaseAlt nlWildPat (ltResult op) ] 442 443 | otherwise -- upper range is larger 444 = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ 445 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) 446 (ltResult op) $ -- Definitely LT 447 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con 448 , mkHsCaseAlt nlWildPat (gtResult op) ] 449 where 450 tag = get_tag data_con 451 tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) 452 453 mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) 454 -- First argument 'a' known to be built with K 455 -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) 456 mkInnerEqAlt op data_con 457 = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $ 458 mkCompareFields op (dataConOrigArgTys data_con) 459 where 460 data_con_RDR = getRdrName data_con 461 bs_needed = take (dataConSourceArity data_con) bs_RDRs 462 463 mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs 464 -- Both constructors known to be nullary 465 -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# 466 mkTagCmp dflags op = 467 untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ 468 unliftedOrdOp intPrimTy op ah_RDR bh_RDR 469 470mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs 471-- Generates nested comparisons for (a1,a2...) against (b1,b2,...) 472-- where the ai,bi have the given types 473mkCompareFields op tys 474 = go tys as_RDRs bs_RDRs 475 where 476 go [] _ _ = eqResult op 477 go [ty] (a:_) (b:_) 478 | isUnliftedType ty = unliftedOrdOp ty op a b 479 | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b) 480 go (ty:tys) (a:as) (b:bs) = mk_compare ty a b 481 (ltResult op) 482 (go tys as bs) 483 (gtResult op) 484 go _ _ _ = panic "mkCompareFields" 485 486 -- (mk_compare ty a b) generates 487 -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> }) 488 -- but with suitable special cases for 489 mk_compare ty a b lt eq gt 490 | isUnliftedType ty 491 = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt 492 | otherwise 493 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr)) 494 [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt, 495 mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq, 496 mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt] 497 where 498 a_expr = nlHsVar a 499 b_expr = nlHsVar b 500 (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty 501 502unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs 503unliftedOrdOp ty op a b 504 = case op of 505 OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr 506 ltTag_Expr eqTag_Expr gtTag_Expr 507 OrdLT -> wrap lt_op 508 OrdLE -> wrap le_op 509 OrdGE -> wrap ge_op 510 OrdGT -> wrap gt_op 511 where 512 (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty 513 wrap prim_op = genPrimOpApp a_expr prim_op b_expr 514 a_expr = nlHsVar a 515 b_expr = nlHsVar b 516 517unliftedCompare :: RdrName -> RdrName 518 -> LHsExpr GhcPs -> LHsExpr GhcPs -- What to cmpare 519 -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs 520 -- Three results 521 -> LHsExpr GhcPs 522-- Return (if a < b then lt else if a == b then eq else gt) 523unliftedCompare lt_op eq_op a_expr b_expr lt eq gt 524 = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $ 525 -- Test (<) first, not (==), because the latter 526 -- is true less often, so putting it first would 527 -- mean more tests (dynamically) 528 nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt 529 where 530 ascribeBool e = nlExprWithTySig e boolTy 531 532nlConWildPat :: DataCon -> LPat GhcPs 533-- The pattern (K {}) 534nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con)) 535 (RecCon (HsRecFields { rec_flds = [] 536 , rec_dotdot = Nothing }))) 537 538{- 539************************************************************************ 540* * 541 Enum instances 542* * 543************************************************************************ 544 545@Enum@ can only be derived for enumeration types. For a type 546\begin{verbatim} 547data Foo ... = N1 | N2 | ... | Nn 548\end{verbatim} 549 550we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a 551@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@). 552 553\begin{verbatim} 554instance ... Enum (Foo ...) where 555 succ x = toEnum (1 + fromEnum x) 556 pred x = toEnum (fromEnum x - 1) 557 558 toEnum i = tag2con_Foo i 559 560 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] 561 562 -- or, really... 563 enumFrom a 564 = case con2tag_Foo a of 565 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) 566 567 enumFromThen a b 568 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo] 569 570 -- or, really... 571 enumFromThen a b 572 = case con2tag_Foo a of { a# -> 573 case con2tag_Foo b of { b# -> 574 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) 575 }} 576\end{verbatim} 577 578For @enumFromTo@ and @enumFromThenTo@, we use the default methods. 579-} 580 581gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) 582gen_Enum_binds loc tycon = do 583 dflags <- getDynFlags 584 return (method_binds dflags, aux_binds) 585 where 586 method_binds dflags = listToBag 587 [ succ_enum dflags 588 , pred_enum dflags 589 , to_enum dflags 590 , enum_from dflags 591 , enum_from_then dflags 592 , from_enum dflags 593 ] 594 aux_binds = listToBag $ map DerivAuxBind 595 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] 596 597 occ_nm = getOccString tycon 598 599 succ_enum dflags 600 = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $ 601 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ 602 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), 603 nlHsVarApps intDataCon_RDR [ah_RDR]]) 604 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") 605 (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) 606 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], 607 nlHsIntLit 1])) 608 609 pred_enum dflags 610 = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $ 611 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ 612 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, 613 nlHsVarApps intDataCon_RDR [ah_RDR]]) 614 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") 615 (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) 616 (nlHsApps plus_RDR 617 [ nlHsVarApps intDataCon_RDR [ah_RDR] 618 , nlHsLit (HsInt noExtField 619 (mkIntegralLit (-1 :: Int)))])) 620 621 to_enum dflags 622 = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $ 623 nlHsIf (nlHsApps and_RDR 624 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], 625 nlHsApps le_RDR [ nlHsVar a_RDR 626 , nlHsVar (maxtag_RDR dflags tycon)]]) 627 (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR]) 628 (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) 629 630 enum_from dflags 631 = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $ 632 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ 633 nlHsApps map_RDR 634 [nlHsVar (tag2con_RDR dflags tycon), 635 nlHsPar (enum_from_to_Expr 636 (nlHsVarApps intDataCon_RDR [ah_RDR]) 637 (nlHsVar (maxtag_RDR dflags tycon)))] 638 639 enum_from_then dflags 640 = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ 641 untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ 642 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ 643 nlHsPar (enum_from_then_to_Expr 644 (nlHsVarApps intDataCon_RDR [ah_RDR]) 645 (nlHsVarApps intDataCon_RDR [bh_RDR]) 646 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], 647 nlHsVarApps intDataCon_RDR [bh_RDR]]) 648 (nlHsIntLit 0) 649 (nlHsVar (maxtag_RDR dflags tycon)) 650 )) 651 652 from_enum dflags 653 = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $ 654 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ 655 (nlHsVarApps intDataCon_RDR [ah_RDR]) 656 657{- 658************************************************************************ 659* * 660 Bounded instances 661* * 662************************************************************************ 663-} 664 665gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) 666gen_Bounded_binds loc tycon 667 | isEnumerationTyCon tycon 668 = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) 669 | otherwise 670 = ASSERT(isSingleton data_cons) 671 (listToBag [ min_bound_1con, max_bound_1con ], emptyBag) 672 where 673 data_cons = tyConDataCons tycon 674 675 ----- enum-flavored: --------------------------- 676 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) 677 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) 678 679 data_con_1 = head data_cons 680 data_con_N = last data_cons 681 data_con_1_RDR = getRdrName data_con_1 682 data_con_N_RDR = getRdrName data_con_N 683 684 ----- single-constructor-flavored: ------------- 685 arity = dataConSourceArity data_con_1 686 687 min_bound_1con = mkHsVarBind loc minBound_RDR $ 688 nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR) 689 max_bound_1con = mkHsVarBind loc maxBound_RDR $ 690 nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR) 691 692{- 693************************************************************************ 694* * 695 Ix instances 696* * 697************************************************************************ 698 699Deriving @Ix@ is only possible for enumeration types and 700single-constructor types. We deal with them in turn. 701 702For an enumeration type, e.g., 703\begin{verbatim} 704 data Foo ... = N1 | N2 | ... | Nn 705\end{verbatim} 706things go not too differently from @Enum@: 707\begin{verbatim} 708instance ... Ix (Foo ...) where 709 range (a, b) 710 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b] 711 712 -- or, really... 713 range (a, b) 714 = case (con2tag_Foo a) of { a# -> 715 case (con2tag_Foo b) of { b# -> 716 map tag2con_Foo (enumFromTo (I# a#) (I# b#)) 717 }} 718 719 -- Generate code for unsafeIndex, because using index leads 720 -- to lots of redundant range tests 721 unsafeIndex c@(a, b) d 722 = case (con2tag_Foo d -# con2tag_Foo a) of 723 r# -> I# r# 724 725 inRange (a, b) c 726 = let 727 p_tag = con2tag_Foo c 728 in 729 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b 730 731 -- or, really... 732 inRange (a, b) c 733 = case (con2tag_Foo a) of { a_tag -> 734 case (con2tag_Foo b) of { b_tag -> 735 case (con2tag_Foo c) of { c_tag -> 736 if (c_tag >=# a_tag) then 737 c_tag <=# b_tag 738 else 739 False 740 }}} 741\end{verbatim} 742(modulo suitable case-ification to handle the unlifted tags) 743 744For a single-constructor type (NB: this includes all tuples), e.g., 745\begin{verbatim} 746 data Foo ... = MkFoo a b Int Double c c 747\end{verbatim} 748we follow the scheme given in Figure~19 of the Haskell~1.2 report 749(p.~147). 750-} 751 752gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) 753 754gen_Ix_binds loc tycon = do 755 dflags <- getDynFlags 756 return $ if isEnumerationTyCon tycon 757 then (enum_ixes dflags, listToBag $ map DerivAuxBind 758 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) 759 else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) 760 where 761 -------------------------------------------------------------- 762 enum_ixes dflags = listToBag 763 [ enum_range dflags 764 , enum_index dflags 765 , enum_inRange dflags 766 ] 767 768 enum_range dflags 769 = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ 770 untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ 771 untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ 772 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ 773 nlHsPar (enum_from_to_Expr 774 (nlHsVarApps intDataCon_RDR [ah_RDR]) 775 (nlHsVarApps intDataCon_RDR [bh_RDR])) 776 777 enum_index dflags 778 = mkSimpleGeneratedFunBind loc unsafeIndex_RDR 779 [noLoc (AsPat noExtField (noLoc c_RDR) 780 (nlTuplePat [a_Pat, nlWildPat] Boxed)), 781 d_Pat] ( 782 untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( 783 untag_Expr dflags tycon [(d_RDR, dh_RDR)] ( 784 let 785 rhs = nlHsVarApps intDataCon_RDR [c_RDR] 786 in 787 nlHsCase 788 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) 789 [mkHsCaseAlt (nlVarPat c_RDR) rhs] 790 )) 791 ) 792 793 -- This produces something like `(ch >= ah) && (ch <= bh)` 794 enum_inRange dflags 795 = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ 796 untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( 797 untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( 798 untag_Expr dflags tycon [(c_RDR, ch_RDR)] ( 799 -- This used to use `if`, which interacts badly with RebindableSyntax. 800 -- See #11396. 801 nlHsApps and_RDR 802 [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR) 803 , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR) 804 ] 805 ))) 806 807 -------------------------------------------------------------- 808 single_con_ixes 809 = listToBag [single_con_range, single_con_index, single_con_inRange] 810 811 data_con 812 = case tyConSingleDataCon_maybe tycon of -- just checking... 813 Nothing -> panic "get_Ix_binds" 814 Just dc -> dc 815 816 con_arity = dataConSourceArity data_con 817 data_con_RDR = getRdrName data_con 818 819 as_needed = take con_arity as_RDRs 820 bs_needed = take con_arity bs_RDRs 821 cs_needed = take con_arity cs_RDRs 822 823 con_pat xs = nlConVarPat data_con_RDR xs 824 con_expr = nlHsVarApps data_con_RDR cs_needed 825 826 -------------------------------------------------------------- 827 single_con_range 828 = mkSimpleGeneratedFunBind loc range_RDR 829 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ 830 noLoc (mkHsComp ListComp stmts con_expr) 831 where 832 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed 833 834 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c) 835 (nlHsApp (nlHsVar range_RDR) 836 (mkLHsVarTuple [a,b])) 837 838 ---------------- 839 single_con_index 840 = mkSimpleGeneratedFunBind loc unsafeIndex_RDR 841 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, 842 con_pat cs_needed] 843 -- We need to reverse the order we consider the components in 844 -- so that 845 -- range (l,u) !! index (l,u) i == i -- when i is in range 846 -- (from http://haskell.org/onlinereport/ix.html) holds. 847 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) 848 where 849 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) 850 mk_index [] = nlHsIntLit 0 851 mk_index [(l,u,i)] = mk_one l u i 852 mk_index ((l,u,i) : rest) 853 = genOpApp ( 854 mk_one l u i 855 ) plus_RDR ( 856 genOpApp ( 857 (nlHsApp (nlHsVar unsafeRangeSize_RDR) 858 (mkLHsVarTuple [l,u])) 859 ) times_RDR (mk_index rest) 860 ) 861 mk_one l u i 862 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] 863 864 ------------------ 865 single_con_inRange 866 = mkSimpleGeneratedFunBind loc inRange_RDR 867 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, 868 con_pat cs_needed] $ 869 if con_arity == 0 870 -- If the product type has no fields, inRange is trivially true 871 -- (see #12853). 872 then true_Expr 873 else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range 874 as_needed bs_needed cs_needed) 875 where 876 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] 877 878{- 879************************************************************************ 880* * 881 Read instances 882* * 883************************************************************************ 884 885Example 886 887 infix 4 %% 888 data T = Int %% Int 889 | T1 { f1 :: Int } 890 | T2 T 891 892instance Read T where 893 readPrec = 894 parens 895 ( prec 4 ( 896 do x <- ReadP.step Read.readPrec 897 expectP (Symbol "%%") 898 y <- ReadP.step Read.readPrec 899 return (x %% y)) 900 +++ 901 prec (appPrec+1) ( 902 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok 903 -- Record construction binds even more tightly than application 904 do expectP (Ident "T1") 905 expectP (Punc '{') 906 x <- Read.readField "f1" (ReadP.reset readPrec) 907 expectP (Punc '}') 908 return (T1 { f1 = x })) 909 +++ 910 prec appPrec ( 911 do expectP (Ident "T2") 912 x <- ReadP.step Read.readPrec 913 return (T2 x)) 914 ) 915 916 readListPrec = readListPrecDefault 917 readList = readListDefault 918 919 920Note [Use expectP] 921~~~~~~~~~~~~~~~~~~ 922Note that we use 923 expectP (Ident "T1") 924rather than 925 Ident "T1" <- lexP 926The latter desugares to inline code for matching the Ident and the 927string, and this can be very voluminous. The former is much more 928compact. Cf #7258, although that also concerned non-linearity in 929the occurrence analyser, a separate issue. 930 931Note [Read for empty data types] 932~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 933What should we get for this? (#7931) 934 data Emp deriving( Read ) -- No data constructors 935 936Here we want 937 read "[]" :: [Emp] to succeed, returning [] 938So we do NOT want 939 instance Read Emp where 940 readPrec = error "urk" 941Rather we want 942 instance Read Emp where 943 readPred = pfail -- Same as choose [] 944 945Because 'pfail' allows the parser to backtrack, but 'error' doesn't. 946These instances are also useful for Read (Either Int Emp), where 947we want to be able to parse (Left 3) just fine. 948-} 949 950gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon 951 -> (LHsBinds GhcPs, BagDerivStuff) 952 953gen_Read_binds get_fixity loc tycon 954 = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) 955 where 956 ----------------------------------------------------------------------- 957 default_readlist 958 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) 959 960 default_readlistprec 961 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) 962 ----------------------------------------------------------------------- 963 964 data_cons = tyConDataCons tycon 965 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons 966 967 read_prec = mkHsVarBind loc readPrec_RDR rhs 968 where 969 rhs | null data_cons -- See Note [Read for empty data types] 970 = nlHsVar pfail_RDR 971 | otherwise 972 = nlHsApp (nlHsVar parens_RDR) 973 (foldr1 mk_alt (read_nullary_cons ++ 974 read_non_nullary_cons)) 975 976 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons 977 978 read_nullary_cons 979 = case nullary_cons of 980 [] -> [] 981 [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] 982 _ -> [nlHsApp (nlHsVar choose_RDR) 983 (nlList (map mk_pair nullary_cons))] 984 -- NB For operators the parens around (:=:) are matched by the 985 -- enclosing "parens" call, so here we must match the naked 986 -- data_con_str con 987 988 match_con con | isSym con_str = [symbol_pat con_str] 989 | otherwise = ident_h_pat con_str 990 where 991 con_str = data_con_str con 992 -- For nullary constructors we must match Ident s for normal constrs 993 -- and Symbol s for operators 994 995 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), 996 result_expr con []] 997 998 read_non_nullary_con data_con 999 | is_infix = mk_parser infix_prec infix_stmts body 1000 | is_record = mk_parser record_prec record_stmts body 1001-- Using these two lines instead allows the derived 1002-- read for infix and record bindings to read the prefix form 1003-- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) 1004-- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) 1005 | otherwise = prefix_parser 1006 where 1007 body = result_expr data_con as_needed 1008 con_str = data_con_str data_con 1009 1010 prefix_parser = mk_parser prefix_prec prefix_stmts body 1011 1012 read_prefix_con 1013 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] 1014 | otherwise = ident_h_pat con_str 1015 1016 read_infix_con 1017 | isSym con_str = [symbol_pat con_str] 1018 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] 1019 1020 prefix_stmts -- T a b c 1021 = read_prefix_con ++ read_args 1022 1023 infix_stmts -- a %% b, or a `T` b 1024 = [read_a1] 1025 ++ read_infix_con 1026 ++ [read_a2] 1027 1028 record_stmts -- T { f1 = a, f2 = b } 1029 = read_prefix_con 1030 ++ [read_punc "{"] 1031 ++ concat (intersperse [read_punc ","] field_stmts) 1032 ++ [read_punc "}"] 1033 1034 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed 1035 1036 con_arity = dataConSourceArity data_con 1037 labels = map flLabel $ dataConFieldLabels data_con 1038 dc_nm = getName data_con 1039 is_infix = dataConIsInfix data_con 1040 is_record = labels `lengthExceeds` 0 1041 as_needed = take con_arity as_RDRs 1042 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con) 1043 (read_a1:read_a2:_) = read_args 1044 1045 prefix_prec = appPrecedence 1046 infix_prec = getPrecedence get_fixity dc_nm 1047 record_prec = appPrecedence + 1 -- Record construction binds even more tightly 1048 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) 1049 1050 ------------------------------------------------------------------------ 1051 -- Helpers 1052 ------------------------------------------------------------------------ 1053 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 1054 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) 1055 , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] 1056 con_app con as = nlHsVarApps (getRdrName con) as -- con as 1057 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) 1058 1059 -- For constructors and field labels ending in '#', we hackily 1060 -- let the lexer generate two tokens, and look for both in sequence 1061 -- Thus [Ident "I"; Symbol "#"]. See #5041 1062 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] 1063 | otherwise = [ ident_pat s ] 1064 1065 bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p 1066 -- See Note [Use expectP] 1067 ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") 1068 symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") 1069 read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<") 1070 1071 data_con_str con = occNameString (getOccName con) 1072 1073 read_arg a ty = ASSERT( not (isUnliftedType ty) ) 1074 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) 1075 1076 -- When reading field labels we might encounter 1077 -- a = 3 1078 -- _a = 3 1079 -- or (#) = 4 1080 -- Note the parens! 1081 read_field lbl a = 1082 [noLoc 1083 (mkBindStmt 1084 (nlVarPat a) 1085 (nlHsApp 1086 read_field 1087 (nlHsVarApps reset_RDR [readPrec_RDR]) 1088 ) 1089 ) 1090 ] 1091 where 1092 lbl_str = unpackFS lbl 1093 mk_read_field read_field_rdr lbl 1094 = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)] 1095 read_field 1096 | isSym lbl_str 1097 = mk_read_field readSymField_RDR lbl_str 1098 | Just (ss, '#') <- snocView lbl_str -- #14918 1099 = mk_read_field readFieldHash_RDR ss 1100 | otherwise 1101 = mk_read_field readField_RDR lbl_str 1102 1103{- 1104************************************************************************ 1105* * 1106 Show instances 1107* * 1108************************************************************************ 1109 1110Example 1111 1112 infixr 5 :^: 1113 1114 data Tree a = Leaf a | Tree a :^: Tree a 1115 1116 instance (Show a) => Show (Tree a) where 1117 1118 showsPrec d (Leaf m) = showParen (d > app_prec) showStr 1119 where 1120 showStr = showString "Leaf " . showsPrec (app_prec+1) m 1121 1122 showsPrec d (u :^: v) = showParen (d > up_prec) showStr 1123 where 1124 showStr = showsPrec (up_prec+1) u . 1125 showString " :^: " . 1126 showsPrec (up_prec+1) v 1127 -- Note: right-associativity of :^: ignored 1128 1129 up_prec = 5 -- Precedence of :^: 1130 app_prec = 10 -- Application has precedence one more than 1131 -- the most tightly-binding operator 1132-} 1133 1134gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon 1135 -> (LHsBinds GhcPs, BagDerivStuff) 1136 1137gen_Show_binds get_fixity loc tycon 1138 = (unitBag shows_prec, emptyBag) 1139 where 1140 data_cons = tyConDataCons tycon 1141 shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons) 1142 comma_space = nlHsVar showCommaSpace_RDR 1143 1144 pats_etc data_con 1145 | nullary_con = -- skip the showParen junk... 1146 ASSERT(null bs_needed) 1147 ([nlWildPat, con_pat], mk_showString_app op_con_str) 1148 | otherwise = 1149 ([a_Pat, con_pat], 1150 showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit 1151 (HsInt noExtField (mkIntegralLit con_prec_plus_one)))) 1152 (nlHsPar (nested_compose_Expr show_thingies))) 1153 where 1154 data_con_RDR = getRdrName data_con 1155 con_arity = dataConSourceArity data_con 1156 bs_needed = take con_arity bs_RDRs 1157 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed 1158 con_pat = nlConVarPat data_con_RDR bs_needed 1159 nullary_con = con_arity == 0 1160 labels = map flLabel $ dataConFieldLabels data_con 1161 lab_fields = length labels 1162 record_syntax = lab_fields > 0 1163 1164 dc_nm = getName data_con 1165 dc_occ_nm = getOccName data_con 1166 con_str = occNameString dc_occ_nm 1167 op_con_str = wrapOpParens con_str 1168 backquote_str = wrapOpBackquotes con_str 1169 1170 show_thingies 1171 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2] 1172 | record_syntax = mk_showString_app (op_con_str ++ " {") : 1173 show_record_args ++ [mk_showString_app "}"] 1174 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args 1175 1176 show_label l = mk_showString_app (nm ++ " = ") 1177 -- Note the spaces around the "=" sign. If we 1178 -- don't have them then we get Foo { x=-1 } and 1179 -- the "=-" parses as a single lexeme. Only the 1180 -- space after the '=' is necessary, but it 1181 -- seems tidier to have them both sides. 1182 where 1183 nm = wrapOpParens (unpackFS l) 1184 1185 show_args = zipWith show_arg bs_needed arg_tys 1186 (show_arg1:show_arg2:_) = show_args 1187 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args 1188 1189 -- Assumption for record syntax: no of fields == no of 1190 -- labelled fields (and in same order) 1191 show_record_args = concat $ 1192 intersperse [comma_space] $ 1193 [ [show_label lbl, arg] 1194 | (lbl,arg) <- zipEqual "gen_Show_binds" 1195 labels show_args ] 1196 1197 show_arg :: RdrName -> Type -> LHsExpr GhcPs 1198 show_arg b arg_ty 1199 | isUnliftedType arg_ty 1200 -- See Note [Deriving and unboxed types] in TcDerivInfer 1201 = with_conv $ 1202 nlHsApps compose_RDR 1203 [mk_shows_app boxed_arg, mk_showString_app postfixMod] 1204 | otherwise 1205 = mk_showsPrec_app arg_prec arg 1206 where 1207 arg = nlHsVar b 1208 boxed_arg = box "Show" arg arg_ty 1209 postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty 1210 with_conv expr 1211 | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty = 1212 nested_compose_Expr 1213 [ mk_showString_app ("(" ++ conv ++ " ") 1214 , expr 1215 , mk_showString_app ")" 1216 ] 1217 | otherwise = expr 1218 1219 -- Fixity stuff 1220 is_infix = dataConIsInfix data_con 1221 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm 1222 arg_prec | record_syntax = 0 -- Record fields don't need parens 1223 | otherwise = con_prec_plus_one 1224 1225wrapOpParens :: String -> String 1226wrapOpParens s | isSym s = '(' : s ++ ")" 1227 | otherwise = s 1228 1229wrapOpBackquotes :: String -> String 1230wrapOpBackquotes s | isSym s = s 1231 | otherwise = '`' : s ++ "`" 1232 1233isSym :: String -> Bool 1234isSym "" = False 1235isSym (c : _) = startsVarSym c || startsConSym c 1236 1237-- | showString :: String -> ShowS 1238mk_showString_app :: String -> LHsExpr GhcPs 1239mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) 1240 1241-- | showsPrec :: Show a => Int -> a -> ShowS 1242mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs 1243mk_showsPrec_app p x 1244 = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x] 1245 1246-- | shows :: Show a => a -> ShowS 1247mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs 1248mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x 1249 1250getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer 1251getPrec is_infix get_fixity nm 1252 | not is_infix = appPrecedence 1253 | otherwise = getPrecedence get_fixity nm 1254 1255appPrecedence :: Integer 1256appPrecedence = fromIntegral maxPrecedence + 1 1257 -- One more than the precedence of the most 1258 -- tightly-binding operator 1259 1260getPrecedence :: (Name -> Fixity) -> Name -> Integer 1261getPrecedence get_fixity nm 1262 = case get_fixity nm of 1263 Fixity _ x _assoc -> fromIntegral x 1264 -- NB: the Report says that associativity is not taken 1265 -- into account for either Read or Show; hence we 1266 -- ignore associativity here 1267 1268{- 1269************************************************************************ 1270* * 1271 Data instances 1272* * 1273************************************************************************ 1274 1275From the data type 1276 1277 data T a b = T1 a b | T2 1278 1279we generate 1280 1281 $cT1 = mkDataCon $dT "T1" Prefix 1282 $cT2 = mkDataCon $dT "T2" Prefix 1283 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2] 1284 -- the [] is for field labels. 1285 1286 instance (Data a, Data b) => Data (T a b) where 1287 gfoldl k z (T1 a b) = z T `k` a `k` b 1288 gfoldl k z T2 = z T2 1289 -- ToDo: add gmapT,Q,M, gfoldr 1290 1291 gunfold k z c = case conIndex c of 1292 I# 1# -> k (k (z T1)) 1293 I# 2# -> z T2 1294 1295 toConstr (T1 _ _) = $cT1 1296 toConstr T2 = $cT2 1297 1298 dataTypeOf _ = $dT 1299 1300 dataCast1 = gcast1 -- If T :: * -> * 1301 dataCast2 = gcast2 -- if T :: * -> * -> * 1302-} 1303 1304gen_Data_binds :: SrcSpan 1305 -> TyCon -- For data families, this is the 1306 -- *representation* TyCon 1307 -> TcM (LHsBinds GhcPs, -- The method bindings 1308 BagDerivStuff) -- Auxiliary bindings 1309gen_Data_binds loc rep_tc 1310 = do { dflags <- getDynFlags 1311 1312 -- Make unique names for the data type and constructor 1313 -- auxiliary bindings. Start with the name of the TyCon/DataCon 1314 -- but that might not be unique: see #12245. 1315 ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc)) 1316 ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName) 1317 (tyConDataCons rep_tc) 1318 ; let dt_rdr = mkRdrUnqual dt_occ 1319 dc_rdrs = map mkRdrUnqual dc_occs 1320 1321 -- OK, now do the work 1322 ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) } 1323 1324gen_data :: DynFlags -> RdrName -> [RdrName] 1325 -> SrcSpan -> TyCon 1326 -> (LHsBinds GhcPs, -- The method bindings 1327 BagDerivStuff) -- Auxiliary bindings 1328gen_data dflags data_type_name constr_names loc rep_tc 1329 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] 1330 `unionBags` gcast_binds, 1331 -- Auxiliary definitions: the data type and constructors 1332 listToBag ( genDataTyCon 1333 : zipWith genDataDataCon data_cons constr_names ) ) 1334 where 1335 data_cons = tyConDataCons rep_tc 1336 n_cons = length data_cons 1337 one_constr = n_cons == 1 1338 genDataTyCon :: DerivStuff 1339 genDataTyCon -- $dT 1340 = DerivHsBind (mkHsVarBind loc data_type_name rhs, 1341 L loc (TypeSig noExtField [L loc data_type_name] sig_ty)) 1342 1343 sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) 1344 rhs = nlHsVar mkDataType_RDR 1345 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc))) 1346 `nlHsApp` nlList (map nlHsVar constr_names) 1347 1348 genDataDataCon :: DataCon -> RdrName -> DerivStuff 1349 genDataDataCon dc constr_name -- $cT1 etc 1350 = DerivHsBind (mkHsVarBind loc constr_name rhs, 1351 L loc (TypeSig noExtField [L loc constr_name] sig_ty)) 1352 where 1353 sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) 1354 rhs = nlHsApps mkConstr_RDR constr_args 1355 1356 constr_args 1357 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag 1358 nlHsVar (data_type_name) -- DataType 1359 , nlHsLit (mkHsString (occNameString dc_occ)) -- String name 1360 , nlList labels -- Field labels 1361 , nlHsVar fixity ] -- Fixity 1362 1363 labels = map (nlHsLit . mkHsString . unpackFS . flLabel) 1364 (dataConFieldLabels dc) 1365 dc_occ = getOccName dc 1366 is_infix = isDataSymOcc dc_occ 1367 fixity | is_infix = infix_RDR 1368 | otherwise = prefix_RDR 1369 1370 ------------ gfoldl 1371 gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons) 1372 1373 gfoldl_eqn con 1374 = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], 1375 foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed) 1376 where 1377 con_name :: RdrName 1378 con_name = getRdrName con 1379 as_needed = take (dataConSourceArity con) as_RDRs 1380 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) 1381 1382 ------------ gunfold 1383 gunfold_bind = mkSimpleGeneratedFunBind loc 1384 gunfold_RDR 1385 [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] 1386 gunfold_rhs 1387 1388 gunfold_rhs 1389 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case 1390 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) 1391 (map gunfold_alt data_cons) 1392 1393 gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) 1394 mk_unfold_rhs dc = foldr nlHsApp 1395 (z_Expr `nlHsApp` nlHsVar (getRdrName dc)) 1396 (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) 1397 1398 mk_unfold_pat dc -- Last one is a wild-pat, to avoid 1399 -- redundant test, and annoying warning 1400 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor 1401 | otherwise = nlConPat intDataCon_RDR 1402 [nlLitPat (HsIntPrim NoSourceText (toInteger tag))] 1403 where 1404 tag = dataConTag dc 1405 1406 ------------ toConstr 1407 toCon_bind = mkFunBindEC 1 loc toConstr_RDR id 1408 (zipWith to_con_eqn data_cons constr_names) 1409 to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) 1410 1411 ------------ dataTypeOf 1412 dataTypeOf_bind = mkSimpleGeneratedFunBind 1413 loc 1414 dataTypeOf_RDR 1415 [nlWildPat] 1416 (nlHsVar data_type_name) 1417 1418 ------------ gcast1/2 1419 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> * 1420 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> * 1421 -- (or nothing if T has neither of these two types) 1422 1423 -- But care is needed for data families: 1424 -- If we have data family D a 1425 -- data instance D (a,b,c) = A | B deriving( Data ) 1426 -- and we want instance ... => Data (D [(a,b,c)]) where ... 1427 -- then we need dataCast1 x = gcast1 x 1428 -- because D :: * -> * 1429 -- even though rep_tc has kind * -> * -> * -> * 1430 -- Hence looking for the kind of fam_tc not rep_tc 1431 -- See #4896 1432 tycon_kind = case tyConFamInst_maybe rep_tc of 1433 Just (fam_tc, _) -> tyConKind fam_tc 1434 Nothing -> tyConKind rep_tc 1435 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR 1436 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR 1437 | otherwise = emptyBag 1438 mk_gcast dataCast_RDR gcast_RDR 1439 = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR] 1440 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) 1441 1442 1443kind1, kind2 :: Kind 1444kind1 = typeToTypeKind 1445kind2 = liftedTypeKind `mkVisFunTy` kind1 1446 1447gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, 1448 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, 1449 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, 1450 constr_RDR, dataType_RDR, 1451 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , 1452 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , 1453 eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , 1454 eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , 1455 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , 1456 eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , 1457 eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, 1458 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , 1459 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , 1460 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, 1461 extendWord8_RDR, extendInt8_RDR, 1462 extendWord16_RDR, extendInt16_RDR :: RdrName 1463gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") 1464gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") 1465toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") 1466dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") 1467dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") 1468dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") 1469gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") 1470gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") 1471mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") 1472constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") 1473mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") 1474dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") 1475conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") 1476prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") 1477infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") 1478 1479eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#") 1480ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#") 1481leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#") 1482gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#") 1483geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#") 1484 1485eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#") 1486ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" ) 1487leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#") 1488gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" ) 1489geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#") 1490 1491eqInt8_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt8#") 1492ltInt8_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt8#" ) 1493leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#") 1494gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" ) 1495geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#") 1496 1497eqInt16_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt16#") 1498ltInt16_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt16#" ) 1499leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#") 1500gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" ) 1501geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#") 1502 1503eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") 1504ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") 1505leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") 1506gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#") 1507geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#") 1508 1509eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#") 1510ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" ) 1511leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#") 1512gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" ) 1513geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#") 1514 1515eqWord16_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord16#") 1516ltWord16_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord16#" ) 1517leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#") 1518gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" ) 1519geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#") 1520 1521eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") 1522ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") 1523leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") 1524gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#") 1525geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#") 1526 1527eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#") 1528ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#") 1529leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#") 1530gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#") 1531geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#") 1532 1533eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##") 1534ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" ) 1535leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##") 1536gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) 1537geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") 1538 1539extendWord8_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord8#") 1540extendInt8_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt8#") 1541 1542extendWord16_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord16#") 1543extendInt16_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt16#") 1544 1545 1546{- 1547************************************************************************ 1548* * 1549 Lift instances 1550* * 1551************************************************************************ 1552 1553Example: 1554 1555 data Foo a = Foo a | a :^: a deriving Lift 1556 1557 ==> 1558 1559 instance (Lift a) => Lift (Foo a) where 1560 lift (Foo a) = [| Foo a |] 1561 lift ((:^:) u v) = [| (:^:) u v |] 1562 1563 liftTyped (Foo a) = [|| Foo a ||] 1564 liftTyped ((:^:) u v) = [|| (:^:) u v ||] 1565-} 1566 1567 1568gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) 1569gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag) 1570 where 1571 lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) 1572 (map (pats_etc mk_exp) data_cons) 1573 liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr) 1574 (map (pats_etc mk_texp) data_cons) 1575 1576 mk_exp = ExpBr noExtField 1577 mk_texp = TExpBr noExtField 1578 data_cons = tyConDataCons tycon 1579 1580 pats_etc mk_bracket data_con 1581 = ([con_pat], lift_Expr) 1582 where 1583 con_pat = nlConVarPat data_con_RDR as_needed 1584 data_con_RDR = getRdrName data_con 1585 con_arity = dataConSourceArity data_con 1586 as_needed = take con_arity as_RDRs 1587 lift_Expr = noLoc (HsBracket noExtField (mk_bracket br_body)) 1588 br_body = nlHsApps (Exact (dataConName data_con)) 1589 (map nlHsVar as_needed) 1590 1591{- 1592************************************************************************ 1593* * 1594 Newtype-deriving instances 1595* * 1596************************************************************************ 1597 1598Note [Newtype-deriving instances] 1599~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1600We take every method in the original instance and `coerce` it to fit 1601into the derived instance. We need type applications on the argument 1602to `coerce` to make it obvious what instantiation of the method we're 1603coercing from. So from, say, 1604 1605 class C a b where 1606 op :: forall c. a -> [b] -> c -> Int 1607 1608 newtype T x = MkT <rep-ty> 1609 1610 instance C a <rep-ty> => C a (T x) where 1611 op = coerce @ (a -> [<rep-ty>] -> c -> Int) 1612 @ (a -> [T x] -> c -> Int) 1613 op :: forall c. a -> [T x] -> c -> Int 1614 1615In addition to the type applications, we also have an explicit 1616type signature on the entire RHS. This brings the method-bound variable 1617`c` into scope over the two type applications. 1618See Note [GND and QuantifiedConstraints] for more information on why this 1619is important. 1620 1621Giving 'coerce' two explicitly-visible type arguments grants us finer control 1622over how it should be instantiated. Recall 1623 1624 coerce :: Coercible a b => a -> b 1625 1626By giving it explicit type arguments we deal with the case where 1627'op' has a higher rank type, and so we must instantiate 'coerce' with 1628a polytype. E.g. 1629 1630 class C a where op :: a -> forall b. b -> b 1631 newtype T x = MkT <rep-ty> 1632 instance C <rep-ty> => C (T x) where 1633 op = coerce @ (<rep-ty> -> forall b. b -> b) 1634 @ (T x -> forall b. b -> b) 1635 op :: T x -> forall b. b -> b 1636 1637The use of type applications is crucial here. If we had tried using only 1638explicit type signatures, like so: 1639 1640 instance C <rep-ty> => C (T x) where 1641 op = coerce (op :: <rep-ty> -> forall b. b -> b) 1642 :: T x -> forall b. b -> b 1643 1644Then GHC will attempt to deeply skolemize the two type signatures, which will 1645wreak havoc with the Coercible solver. Therefore, we instead use type 1646applications, which do not deeply skolemize and thus avoid this issue. 1647The downside is that we currently require -XImpredicativeTypes to permit this 1648polymorphic type instantiation, so we have to switch that flag on locally in 1649TcDeriv.genInst. See #8503 for more discussion. 1650 1651Note [Newtype-deriving trickiness] 1652~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1653Consider (#12768): 1654 class C a where { op :: D a => a -> a } 1655 1656 instance C a => C [a] where { op = opList } 1657 1658 opList :: (C a, D [a]) => [a] -> [a] 1659 opList = ... 1660 1661Now suppose we try GND on this: 1662 newtype N a = MkN [a] deriving( C ) 1663 1664The GND is expecting to get an implementation of op for N by 1665coercing opList, thus: 1666 1667 instance C a => C (N a) where { op = opN } 1668 1669 opN :: (C a, D (N a)) => N a -> N a 1670 opN = coerce @([a] -> [a]) 1671 @([N a] -> [N a] 1672 opList :: D (N a) => [N a] -> [N a] 1673 1674But there is no reason to suppose that (D [a]) and (D (N a)) 1675are inter-coercible; these instances might completely different. 1676So GHC rightly rejects this code. 1677 1678Note [GND and QuantifiedConstraints] 1679~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1680Consider the following example from #15290: 1681 1682 class C m where 1683 join :: m (m a) -> m a 1684 1685 newtype T m a = MkT (m a) 1686 1687 deriving instance 1688 (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => 1689 C (T m) 1690 1691The code that GHC used to generate for this was: 1692 1693 instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => 1694 C (T m) where 1695 join = coerce @(forall a. m (m a) -> m a) 1696 @(forall a. T m (T m a) -> T m a) 1697 join 1698 1699This instantiates `coerce` at a polymorphic type, a form of impredicative 1700polymorphism, so we're already on thin ice. And in fact the ice breaks, 1701as we'll explain: 1702 1703The call to `coerce` gives rise to: 1704 1705 Coercible (forall a. m (m a) -> m a) 1706 (forall a. T m (T m a) -> T m a) 1707 1708And that simplified to the following implication constraint: 1709 1710 forall a <no-ev>. m (T m a) ~R# m (m a) 1711 1712But because this constraint is under a `forall`, inside a type, we have to 1713prove it *without computing any term evidence* (hence the <no-ev>). Alas, we 1714*must* generate a term-level evidence binding in order to instantiate the 1715quantified constraint! In response, GHC currently chooses not to use such 1716a quantified constraint. 1717See Note [Instances in no-evidence implications] in TcInteract. 1718 1719But this isn't the death knell for combining QuantifiedConstraints with GND. 1720On the contrary, if we generate GND bindings in a slightly different way, then 1721we can avoid this situation altogether. Instead of applying `coerce` to two 1722polymorphic types, we instead let an explicit type signature do the polymorphic 1723instantiation, and omit the `forall`s in the type applications. 1724More concretely, we generate the following code instead: 1725 1726 instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => 1727 C (T m) where 1728 join = coerce @( m (m a) -> m a) 1729 @(T m (T m a) -> T m a) 1730 join :: forall a. T m (T m a) -> T m a 1731 1732Now the visible type arguments are both monotypes, so we need do any of this 1733funny quantified constraint instantiation business. 1734 1735You might think that that second @(T m (T m a) -> T m a) argument is redundant 1736in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type 1737signature, but in fact leaving it off will break this example (from the 1738T15290d test case): 1739 1740 class C a where 1741 c :: Int -> forall b. b -> a 1742 1743 instance C Int 1744 1745 instance C Age where 1746 c = coerce @(Int -> forall b. b -> Int) 1747 c :: Int -> forall b. b -> Age 1748 1749That is because the explicit type signature deeply skolemizes the forall-bound 1750`b`, which wreaks havoc with the `Coercible` solver. An additional visible type 1751argument of @(Int -> forall b. b -> Age) is enough to prevent this. 1752 1753Be aware that the use of an explicit type signature doesn't /solve/ this 1754problem; it just makes it less likely to occur. For example, if a class has 1755a truly higher-rank type like so: 1756 1757 class CProblem m where 1758 op :: (forall b. ... (m b) ...) -> Int 1759 1760Then the same situation will arise again. But at least it won't arise for the 1761common case of methods with ordinary, prenex-quantified types. 1762 1763Note [GND and ambiguity] 1764~~~~~~~~~~~~~~~~~~~~~~~~ 1765We make an effort to make the code generated through GND be robust w.r.t. 1766ambiguous type variables. As one example, consider the following example 1767(from #15637): 1768 1769 class C a where f :: String 1770 instance C () where f = "foo" 1771 newtype T = T () deriving C 1772 1773A naïve attempt and generating a C T instance would be: 1774 1775 instance C T where 1776 f = coerce @String @String f 1777 :: String 1778 1779This isn't going to typecheck, however, since GHC doesn't know what to 1780instantiate the type variable `a` with in the call to `f` in the method body. 1781(Note that `f :: forall a. String`!) To compensate for the possibility of 1782ambiguity here, we explicitly instantiate `a` like so: 1783 1784 instance C T where 1785 f = coerce @String @String (f @()) 1786 :: String 1787 1788All better now. 1789-} 1790 1791gen_Newtype_binds :: SrcSpan 1792 -> Class -- the class being derived 1793 -> [TyVar] -- the tvs in the instance head (this includes 1794 -- the tvs from both the class types and the 1795 -- newtype itself) 1796 -> [Type] -- instance head parameters (incl. newtype) 1797 -> Type -- the representation type 1798 -> TcM (LHsBinds GhcPs, BagDerivStuff) 1799-- See Note [Newtype-deriving instances] 1800gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty 1801 = do let ats = classATs cls 1802 atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats ) 1803 mapM mk_atf_inst ats 1804 return ( listToBag $ map mk_bind (classMethods cls) 1805 , listToBag $ map DerivFamInst atf_insts ) 1806 where 1807 mk_bind :: Id -> LHsBind GhcPs 1808 mk_bind meth_id 1809 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch 1810 (mkPrefixFunRhs (L loc meth_RDR)) 1811 [] rhs_expr] 1812 where 1813 Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id 1814 (_, _, from_tau) = tcSplitSigmaTy from_ty 1815 (_, _, to_tau) = tcSplitSigmaTy to_ty 1816 1817 meth_RDR = getRdrName meth_id 1818 1819 rhs_expr = nlHsVar (getRdrName coerceId) 1820 `nlHsAppType` from_tau 1821 `nlHsAppType` to_tau 1822 `nlHsApp` meth_app 1823 `nlExprWithTySig` to_ty 1824 1825 -- The class method, applied to all of the class instance types 1826 -- (including the representation type) to avoid potential ambiguity. 1827 -- See Note [GND and ambiguity] 1828 meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $ 1829 filterOutInferredTypes (classTyCon cls) underlying_inst_tys 1830 -- Filter out any inferred arguments, since they can't be 1831 -- applied with visible type application. 1832 1833 mk_atf_inst :: TyCon -> TcM FamInst 1834 mk_atf_inst fam_tc = do 1835 rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) 1836 rep_lhs_tys 1837 let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' 1838 fam_tc rep_lhs_tys rep_rhs_ty 1839 -- Check (c) from Note [GND and associated type families] in TcDeriv 1840 checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) 1841 newFamInst SynFamilyInst axiom 1842 where 1843 cls_tvs = classTyVars cls 1844 in_scope = mkInScopeSet $ mkVarSet inst_tvs 1845 lhs_env = zipTyEnv cls_tvs inst_tys 1846 lhs_subst = mkTvSubst in_scope lhs_env 1847 rhs_env = zipTyEnv cls_tvs underlying_inst_tys 1848 rhs_subst = mkTvSubst in_scope rhs_env 1849 fam_tvs = tyConTyVars fam_tc 1850 rep_lhs_tys = substTyVars lhs_subst fam_tvs 1851 rep_rhs_tys = substTyVars rhs_subst fam_tvs 1852 rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys 1853 rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys 1854 (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs 1855 rep_tvs' = scopedSort rep_tvs 1856 rep_cvs' = scopedSort rep_cvs 1857 1858 -- Same as inst_tys, but with the last argument type replaced by the 1859 -- representation type. 1860 underlying_inst_tys :: [Type] 1861 underlying_inst_tys = changeLast inst_tys rhs_ty 1862 1863nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs 1864nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) 1865 where 1866 hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s) 1867 1868nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs 1869nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty 1870 where 1871 hs_ty = mkLHsSigWcType (typeToLHsType s) 1872 1873mkCoerceClassMethEqn :: Class -- the class being derived 1874 -> [TyVar] -- the tvs in the instance head (this includes 1875 -- the tvs from both the class types and the 1876 -- newtype itself) 1877 -> [Type] -- instance head parameters (incl. newtype) 1878 -> Type -- the representation type 1879 -> Id -- the method to look at 1880 -> Pair Type 1881-- See Note [Newtype-deriving instances] 1882-- See also Note [Newtype-deriving trickiness] 1883-- The pair is the (from_type, to_type), where to_type is 1884-- the type of the method we are trying to get 1885mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id 1886 = Pair (substTy rhs_subst user_meth_ty) 1887 (substTy lhs_subst user_meth_ty) 1888 where 1889 cls_tvs = classTyVars cls 1890 in_scope = mkInScopeSet $ mkVarSet inst_tvs 1891 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys) 1892 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty)) 1893 (_class_tvs, _class_constraint, user_meth_ty) 1894 = tcSplitMethodTy (varType id) 1895 1896{- 1897************************************************************************ 1898* * 1899\subsection{Generating extra binds (@con2tag@ and @tag2con@)} 1900* * 1901************************************************************************ 1902 1903\begin{verbatim} 1904data Foo ... = ... 1905 1906con2tag_Foo :: Foo ... -> Int# 1907tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# 1908maxtag_Foo :: Int -- ditto (NB: not unlifted) 1909\end{verbatim} 1910 1911The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) 1912fiddling around. 1913-} 1914 1915genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec 1916 -> (LHsBind GhcPs, LSig GhcPs) 1917genAuxBindSpec dflags loc (DerivCon2Tag tycon) 1918 = (mkFunBindSE 0 loc rdr_name eqns, 1919 L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) 1920 where 1921 rdr_name = con2tag_RDR dflags tycon 1922 1923 sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ 1924 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ 1925 mkParentType tycon `mkVisFunTy` intPrimTy 1926 1927 lots_of_constructors = tyConFamilySize tycon > 8 1928 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS 1929 -- but we don't do vectored returns any more. 1930 1931 eqns | lots_of_constructors = [get_tag_eqn] 1932 | otherwise = map mk_eqn (tyConDataCons tycon) 1933 1934 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) 1935 1936 mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs) 1937 mk_eqn con = ([nlWildConPat con], 1938 nlHsLit (HsIntPrim NoSourceText 1939 (toInteger ((dataConTag con) - fIRST_TAG)))) 1940 1941genAuxBindSpec dflags loc (DerivTag2Con tycon) 1942 = (mkFunBindSE 0 loc rdr_name 1943 [([nlConVarPat intDataCon_RDR [a_RDR]], 1944 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], 1945 L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) 1946 where 1947 sig_ty = mkLHsSigWcType $ L loc $ 1948 XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ 1949 intTy `mkVisFunTy` mkParentType tycon 1950 1951 rdr_name = tag2con_RDR dflags tycon 1952 1953genAuxBindSpec dflags loc (DerivMaxTag tycon) 1954 = (mkHsVarBind loc rdr_name rhs, 1955 L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) 1956 where 1957 rdr_name = maxtag_RDR dflags tycon 1958 sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy))) 1959 rhs = nlHsApp (nlHsVar intDataCon_RDR) 1960 (nlHsLit (HsIntPrim NoSourceText max_tag)) 1961 max_tag = case (tyConDataCons tycon) of 1962 data_cons -> toInteger ((length data_cons) - fIRST_TAG) 1963 1964type SeparateBagsDerivStuff = 1965 -- AuxBinds and SYB bindings 1966 ( Bag (LHsBind GhcPs, LSig GhcPs) 1967 -- Extra family instances (used by Generic and DeriveAnyClass) 1968 , Bag (FamInst) ) 1969 1970genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff 1971genAuxBinds dflags loc b = genAuxBinds' b2 where 1972 (b1,b2) = partitionBagWith splitDerivAuxBind b 1973 splitDerivAuxBind (DerivAuxBind x) = Left x 1974 splitDerivAuxBind x = Right x 1975 1976 rm_dups = foldr dup_check emptyBag 1977 dup_check a b = if anyBag (== a) b then b else consBag a b 1978 1979 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff 1980 genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1) 1981 , emptyBag ) 1982 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff 1983 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before 1984 f (DerivHsBind b) = add1 b 1985 f (DerivFamInst t) = add2 t 1986 1987 add1 x (a,b) = (x `consBag` a,b) 1988 add2 x (a,b) = (a,x `consBag` b) 1989 1990mkParentType :: TyCon -> Type 1991-- Turn the representation tycon of a family into 1992-- a use of its family constructor 1993mkParentType tc 1994 = case tyConFamInst_maybe tc of 1995 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) 1996 Just (fam_tc,tys) -> mkTyConApp fam_tc tys 1997 1998{- 1999************************************************************************ 2000* * 2001\subsection{Utility bits for generating bindings} 2002* * 2003************************************************************************ 2004-} 2005 2006-- | Make a function binding. If no equations are given, produce a function 2007-- with the given arity that produces a stock error. 2008mkFunBindSE :: Arity -> SrcSpan -> RdrName 2009 -> [([LPat GhcPs], LHsExpr GhcPs)] 2010 -> LHsBind GhcPs 2011mkFunBindSE arity loc fun pats_and_exprs 2012 = mkRdrFunBindSE arity (L loc fun) matches 2013 where 2014 matches = [mkMatch (mkPrefixFunRhs (L loc fun)) 2015 (map (parenthesizePat appPrec) p) e 2016 (noLoc emptyLocalBinds) 2017 | (p,e) <-pats_and_exprs] 2018 2019mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] 2020 -> LHsBind GhcPs 2021mkRdrFunBind fun@(L loc _fun_rdr) matches 2022 = L loc (mkFunBind Generated fun matches) 2023 2024-- | Make a function binding. If no equations are given, produce a function 2025-- with the given arity that uses an empty case expression for the last 2026-- argument that is passes to the given function to produce the right-hand 2027-- side. 2028mkFunBindEC :: Arity -> SrcSpan -> RdrName 2029 -> (LHsExpr GhcPs -> LHsExpr GhcPs) 2030 -> [([LPat GhcPs], LHsExpr GhcPs)] 2031 -> LHsBind GhcPs 2032mkFunBindEC arity loc fun catch_all pats_and_exprs 2033 = mkRdrFunBindEC arity catch_all (L loc fun) matches 2034 where 2035 matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) 2036 (map (parenthesizePat appPrec) p) e 2037 (noLoc emptyLocalBinds) 2038 | (p,e) <- pats_and_exprs ] 2039 2040-- | Produces a function binding. When no equations are given, it generates 2041-- a binding of the given arity and an empty case expression 2042-- for the last argument that it passes to the given function to produce 2043-- the right-hand side. 2044mkRdrFunBindEC :: Arity 2045 -> (LHsExpr GhcPs -> LHsExpr GhcPs) 2046 -> Located RdrName 2047 -> [LMatch GhcPs (LHsExpr GhcPs)] 2048 -> LHsBind GhcPs 2049mkRdrFunBindEC arity catch_all 2050 fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') 2051 where 2052 -- Catch-all eqn looks like 2053 -- fmap _ z = case z of {} 2054 -- or 2055 -- traverse _ z = pure (case z of) 2056 -- or 2057 -- foldMap _ z = mempty 2058 -- It's needed if there no data cons at all, 2059 -- which can happen with -XEmptyDataDecls 2060 -- See #4302 2061 matches' = if null matches 2062 then [mkMatch (mkPrefixFunRhs fun) 2063 (replicate (arity - 1) nlWildPat ++ [z_Pat]) 2064 (catch_all $ nlHsCase z_Expr []) 2065 (noLoc emptyLocalBinds)] 2066 else matches 2067 2068-- | Produces a function binding. When there are no equations, it generates 2069-- a binding with the given arity that produces an error based on the name of 2070-- the type of the last argument. 2071mkRdrFunBindSE :: Arity -> Located RdrName -> 2072 [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs 2073mkRdrFunBindSE arity 2074 fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') 2075 where 2076 -- Catch-all eqn looks like 2077 -- compare _ _ = error "Void compare" 2078 -- It's needed if there no data cons at all, 2079 -- which can happen with -XEmptyDataDecls 2080 -- See #4302 2081 matches' = if null matches 2082 then [mkMatch (mkPrefixFunRhs fun) 2083 (replicate arity nlWildPat) 2084 (error_Expr str) (noLoc emptyLocalBinds)] 2085 else matches 2086 str = "Void " ++ occNameString (rdrNameOcc fun_rdr) 2087 2088 2089box :: String -- The class involved 2090 -> LHsExpr GhcPs -- The argument 2091 -> Type -- The argument type 2092 -> LHsExpr GhcPs -- Boxed version of the arg 2093-- See Note [Deriving and unboxed types] in TcDerivInfer 2094box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg 2095 2096--------------------- 2097primOrdOps :: String -- The class involved 2098 -> Type -- The type 2099 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt) 2100-- See Note [Deriving and unboxed types] in TcDerivInfer 2101primOrdOps str ty = assoc_ty_id str ordOpTbl ty 2102 2103ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] 2104ordOpTbl 2105 = [(charPrimTy , (ltChar_RDR , leChar_RDR 2106 , eqChar_RDR , geChar_RDR , gtChar_RDR )) 2107 ,(intPrimTy , (ltInt_RDR , leInt_RDR 2108 , eqInt_RDR , geInt_RDR , gtInt_RDR )) 2109 ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR 2110 , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) 2111 ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR 2112 , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) 2113 ,(wordPrimTy , (ltWord_RDR , leWord_RDR 2114 , eqWord_RDR , geWord_RDR , gtWord_RDR )) 2115 ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR 2116 , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) 2117 ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR 2118 , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) 2119 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR 2120 , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) 2121 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR 2122 , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) 2123 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR 2124 , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] 2125 2126-- A mapping from a primitive type to a function that constructs its boxed 2127-- version. 2128-- NOTE: Int8#/Word8# will become Int/Word. 2129boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] 2130boxConTbl = 2131 [ (charPrimTy , nlHsApp (nlHsVar $ getRdrName charDataCon)) 2132 , (intPrimTy , nlHsApp (nlHsVar $ getRdrName intDataCon)) 2133 , (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon )) 2134 , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon )) 2135 , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon)) 2136 , (int8PrimTy, 2137 nlHsApp (nlHsVar $ getRdrName intDataCon) 2138 . nlHsApp (nlHsVar extendInt8_RDR)) 2139 , (word8PrimTy, 2140 nlHsApp (nlHsVar $ getRdrName wordDataCon) 2141 . nlHsApp (nlHsVar extendWord8_RDR)) 2142 , (int16PrimTy, 2143 nlHsApp (nlHsVar $ getRdrName intDataCon) 2144 . nlHsApp (nlHsVar extendInt16_RDR)) 2145 , (word16PrimTy, 2146 nlHsApp (nlHsVar $ getRdrName wordDataCon) 2147 . nlHsApp (nlHsVar extendWord16_RDR)) 2148 ] 2149 2150 2151-- | A table of postfix modifiers for unboxed values. 2152postfixModTbl :: [(Type, String)] 2153postfixModTbl 2154 = [(charPrimTy , "#" ) 2155 ,(intPrimTy , "#" ) 2156 ,(wordPrimTy , "##") 2157 ,(floatPrimTy , "#" ) 2158 ,(doublePrimTy, "##") 2159 ,(int8PrimTy, "#") 2160 ,(word8PrimTy, "##") 2161 ,(int16PrimTy, "#") 2162 ,(word16PrimTy, "##") 2163 ] 2164 2165primConvTbl :: [(Type, String)] 2166primConvTbl = 2167 [ (int8PrimTy, "narrowInt8#") 2168 , (word8PrimTy, "narrowWord8#") 2169 , (int16PrimTy, "narrowInt16#") 2170 , (word16PrimTy, "narrowWord16#") 2171 ] 2172 2173litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] 2174litConTbl 2175 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR)) 2176 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR) 2177 . nlHsApp (nlHsVar toInteger_RDR)) 2178 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR) 2179 . nlHsApp (nlHsVar toInteger_RDR)) 2180 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR) 2181 . nlHsApp (nlHsApp 2182 (nlHsVar map_RDR) 2183 (compose_RDR `nlHsApps` 2184 [ nlHsVar fromIntegral_RDR 2185 , nlHsVar fromEnum_RDR 2186 ]))) 2187 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR) 2188 . nlHsApp (nlHsVar toRational_RDR)) 2189 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR) 2190 . nlHsApp (nlHsVar toRational_RDR)) 2191 ] 2192 2193-- | Lookup `Type` in an association list. 2194assoc_ty_id :: HasCallStack => String -- The class involved 2195 -> [(Type,a)] -- The table 2196 -> Type -- The type 2197 -> a -- The result of the lookup 2198assoc_ty_id cls_str tbl ty 2199 | Just a <- assoc_ty_id_maybe tbl ty = a 2200 | otherwise = 2201 pprPanic "Error in deriving:" 2202 (text "Can't derive" <+> text cls_str <+> 2203 text "for primitive type" <+> ppr ty) 2204 2205-- | Lookup `Type` in an association list. 2206assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a 2207assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl 2208 2209----------------------------------------------------------------------- 2210 2211and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs 2212and_Expr a b = genOpApp a and_RDR b 2213 2214----------------------------------------------------------------------- 2215 2216eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs 2217eq_Expr ty a b 2218 | not (isUnliftedType ty) = genOpApp a eq_RDR b 2219 | otherwise = genPrimOpApp a prim_eq b 2220 where 2221 (_, _, prim_eq, _, _) = primOrdOps "Eq" ty 2222 2223untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)] 2224 -> LHsExpr GhcPs -> LHsExpr GhcPs 2225untag_Expr _ _ [] expr = expr 2226untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr 2227 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon) 2228 [untag_this])) {-of-} 2229 [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)] 2230 2231enum_from_to_Expr 2232 :: LHsExpr GhcPs -> LHsExpr GhcPs 2233 -> LHsExpr GhcPs 2234enum_from_then_to_Expr 2235 :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs 2236 -> LHsExpr GhcPs 2237 2238enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 2239enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 2240 2241showParen_Expr 2242 :: LHsExpr GhcPs -> LHsExpr GhcPs 2243 -> LHsExpr GhcPs 2244 2245showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 2246 2247nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs 2248 2249nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty 2250nested_compose_Expr [e] = parenify e 2251nested_compose_Expr (e:es) 2252 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) 2253 2254-- impossible_Expr is used in case RHSs that should never happen. 2255-- We generate these to keep the desugarer from complaining that they *might* happen! 2256error_Expr :: String -> LHsExpr GhcPs 2257error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) 2258 2259-- illegal_Expr is used when signalling error conditions in the RHS of a derived 2260-- method. It is currently only used by Enum.{succ,pred} 2261illegal_Expr :: String -> String -> String -> LHsExpr GhcPs 2262illegal_Expr meth tp msg = 2263 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) 2264 2265-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you 2266-- to include the value of a_RDR in the error string. 2267illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs 2268illegal_toEnum_tag tp maxtag = 2269 nlHsApp (nlHsVar error_RDR) 2270 (nlHsApp (nlHsApp (nlHsVar append_RDR) 2271 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag (")))) 2272 (nlHsApp (nlHsApp (nlHsApp 2273 (nlHsVar showsPrec_RDR) 2274 (nlHsIntLit 0)) 2275 (nlHsVar a_RDR)) 2276 (nlHsApp (nlHsApp 2277 (nlHsVar append_RDR) 2278 (nlHsLit (mkHsString ") is outside of enumeration's range (0,"))) 2279 (nlHsApp (nlHsApp (nlHsApp 2280 (nlHsVar showsPrec_RDR) 2281 (nlHsIntLit 0)) 2282 (nlHsVar maxtag)) 2283 (nlHsLit (mkHsString ")")))))) 2284 2285parenify :: LHsExpr GhcPs -> LHsExpr GhcPs 2286parenify e@(L _ (HsVar _ _)) = e 2287parenify e = mkHsPar e 2288 2289-- genOpApp wraps brackets round the operator application, so that the 2290-- renamer won't subsequently try to re-associate it. 2291genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs 2292genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) 2293 2294genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs 2295genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) 2296 2297a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR 2298 :: RdrName 2299a_RDR = mkVarUnqual (fsLit "a") 2300b_RDR = mkVarUnqual (fsLit "b") 2301c_RDR = mkVarUnqual (fsLit "c") 2302d_RDR = mkVarUnqual (fsLit "d") 2303f_RDR = mkVarUnqual (fsLit "f") 2304k_RDR = mkVarUnqual (fsLit "k") 2305z_RDR = mkVarUnqual (fsLit "z") 2306ah_RDR = mkVarUnqual (fsLit "a#") 2307bh_RDR = mkVarUnqual (fsLit "b#") 2308ch_RDR = mkVarUnqual (fsLit "c#") 2309dh_RDR = mkVarUnqual (fsLit "d#") 2310 2311as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] 2312as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] 2313bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] 2314cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] 2315 2316a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, 2317 true_Expr, pure_Expr :: LHsExpr GhcPs 2318a_Expr = nlHsVar a_RDR 2319b_Expr = nlHsVar b_RDR 2320c_Expr = nlHsVar c_RDR 2321z_Expr = nlHsVar z_RDR 2322ltTag_Expr = nlHsVar ltTag_RDR 2323eqTag_Expr = nlHsVar eqTag_RDR 2324gtTag_Expr = nlHsVar gtTag_RDR 2325false_Expr = nlHsVar false_RDR 2326true_Expr = nlHsVar true_RDR 2327pure_Expr = nlHsVar pure_RDR 2328 2329a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs 2330a_Pat = nlVarPat a_RDR 2331b_Pat = nlVarPat b_RDR 2332c_Pat = nlVarPat c_RDR 2333d_Pat = nlVarPat d_RDR 2334k_Pat = nlVarPat k_RDR 2335z_Pat = nlVarPat z_RDR 2336 2337minusInt_RDR, tagToEnum_RDR :: RdrName 2338minusInt_RDR = getRdrName (primOpId IntSubOp ) 2339tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) 2340 2341con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName 2342-- Generates Orig s RdrName, for the binding positions 2343con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc 2344tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc 2345maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc 2346 2347mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName 2348mk_tc_deriv_name dflags tycon occ_fun = 2349 mkAuxBinderName dflags (tyConName tycon) occ_fun 2350 2351mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName 2352-- ^ Make a top-level binder name for an auxiliary binding for a parent name 2353-- See Note [Auxiliary binders] 2354mkAuxBinderName dflags parent occ_fun 2355 = mkRdrUnqual (occ_fun stable_parent_occ) 2356 where 2357 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string 2358 stable_string 2359 | hasPprDebug dflags = parent_stable 2360 | otherwise = parent_stable_hash 2361 parent_stable = nameStableString parent 2362 parent_stable_hash = 2363 let Fingerprint high low = fingerprintString parent_stable 2364 in toBase62 high ++ toBase62Padded low 2365 -- See Note [Base 62 encoding 128-bit integers] in Encoding 2366 parent_occ = nameOccName parent 2367 2368 2369{- 2370Note [Auxiliary binders] 2371~~~~~~~~~~~~~~~~~~~~~~~~ 2372We often want to make a top-level auxiliary binding. E.g. for comparison we haev 2373 2374 instance Ord T where 2375 compare a b = $con2tag a `compare` $con2tag b 2376 2377 $con2tag :: T -> Int 2378 $con2tag = ...code.... 2379 2380Of course these top-level bindings should all have distinct name, and we are 2381generating RdrNames here. We can't just use the TyCon or DataCon to distinguish 2382because with standalone deriving two imported TyCons might both be called T! 2383(See #7947.) 2384 2385So we use package name, module name and the name of the parent 2386(T in this example) as part of the OccName we generate for the new binding. 2387To make the symbol names short we take a base62 hash of the full name. 2388 2389In the past we used the *unique* from the parent, but that's not stable across 2390recompilations as uniques are nondeterministic. 2391-} 2392