1{-# LANGUAGE CPP #-} 2{-# LANGUAGE PatternGuards #-} 3{-# LANGUAGE BangPatterns #-} 4 5#if __GLASGOW_HASKELL__ >= 704 6{-# LANGUAGE Unsafe #-} 7#endif 8 9#ifndef MIN_VERSION_template_haskell 10#define MIN_VERSION_template_haskell(x,y,z) 1 11#endif 12----------------------------------------------------------------------------- 13-- | 14-- Copyright : (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott 15-- License : BSD-style (see the file LICENSE) 16-- 17-- Maintainer : Edward Kmett <ekmett@gmail.com> 18-- Stability : provisional 19-- Portability : portable 20-- 21-- Functions to mechanically derive 'Bifunctor', 'Bifoldable', 22-- or 'Bitraversable' instances, or to splice their functions directly into 23-- source code. You need to enable the @TemplateHaskell@ language extension 24-- in order to use this module. 25---------------------------------------------------------------------------- 26 27module Data.Bifunctor.TH ( 28 -- * @derive@- functions 29 -- $derive 30 -- * @make@- functions 31 -- $make 32 -- * 'Bifunctor' 33 deriveBifunctor 34 , deriveBifunctorOptions 35 , makeBimap 36 , makeBimapOptions 37 -- * 'Bifoldable' 38 , deriveBifoldable 39 , deriveBifoldableOptions 40 , makeBifold 41 , makeBifoldOptions 42 , makeBifoldMap 43 , makeBifoldMapOptions 44 , makeBifoldr 45 , makeBifoldrOptions 46 , makeBifoldl 47 , makeBifoldlOptions 48 -- * 'Bitraversable' 49 , deriveBitraversable 50 , deriveBitraversableOptions 51 , makeBitraverse 52 , makeBitraverseOptions 53 , makeBisequenceA 54 , makeBisequenceAOptions 55 , makeBimapM 56 , makeBimapMOptions 57 , makeBisequence 58 , makeBisequenceOptions 59 -- * 'Options' 60 , Options(..) 61 , defaultOptions 62 ) where 63 64import Control.Monad (guard, unless, when, zipWithM) 65 66import Data.Bifunctor.TH.Internal 67import Data.Either (rights) 68import Data.List 69import qualified Data.Map as Map (fromList, keys, lookup, size) 70import Data.Maybe 71 72import Language.Haskell.TH.Datatype 73import Language.Haskell.TH.Lib 74import Language.Haskell.TH.Ppr 75import Language.Haskell.TH.Syntax 76 77------------------------------------------------------------------------------- 78-- User-facing API 79------------------------------------------------------------------------------- 80 81-- | Options that further configure how the functions in "Data.Bifunctor.TH" 82-- should behave. 83newtype Options = Options 84 { emptyCaseBehavior :: Bool 85 -- ^ If 'True', derived instances for empty data types (i.e., ones with 86 -- no data constructors) will use the @EmptyCase@ language extension. 87 -- If 'False', derived instances will simply use 'seq' instead. 88 -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only 89 -- available in 7.8 or later.) 90 } deriving (Eq, Ord, Read, Show) 91 92-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to 93-- prevent users from having to enable that extension at use sites.) 94defaultOptions :: Options 95defaultOptions = Options { emptyCaseBehavior = False } 96 97{- $derive 98 99'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically 100generate their respective class instances for a given data type, newtype, or data 101family instance that has at least two type variable. Examples: 102 103@ 104{-# LANGUAGE TemplateHaskell #-} 105import Data.Bifunctor.TH 106 107data Pair a b = Pair a b 108$('deriveBifunctor' ''Pair) -- instance Bifunctor Pair where ... 109 110data WrapLeftPair f g a b = WrapLeftPair (f a) (g a b) 111$('deriveBifoldable' ''WrapLeftPair) 112-- instance (Foldable f, Bifoldable g) => Bifoldable (WrapLeftPair f g) where ... 113@ 114 115If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later), 116the @derive@ functions can be used data family instances (which requires the 117@-XTypeFamilies@ extension). To do so, pass the name of a data or newtype instance 118constructor (NOT a data family name!) to a @derive@ function. Note that the 119generated code may require the @-XFlexibleInstances@ extension. Example: 120 121@ 122{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} 123import Data.Bifunctor.TH 124 125class AssocClass a b c where 126 data AssocData a b c 127instance AssocClass Int b c where 128 data AssocData Int b c = AssocDataInt1 Int | AssocDataInt2 b c 129$('deriveBitraversable' 'AssocDataInt1) -- instance Bitraversable (AssocData Int) where ... 130-- Alternatively, one could use $(deriveBitraversable 'AssocDataInt2) 131@ 132 133Note that there are some limitations: 134 135* The 'Name' argument to a @derive@ function must not be a type synonym. 136 137* With a @derive@ function, the last two type variables must both be of kind @*@. 138 Other type variables of kind @* -> *@ are assumed to require a 'Functor', 139 'Foldable', or 'Traversable' constraint (depending on which @derive@ function is 140 used), and other type variables of kind @* -> * -> *@ are assumed to require an 141 'Bifunctor', 'Bifoldable', or 'Bitraversable' constraint. If your data type 142 doesn't meet these assumptions, use a @make@ function. 143 144* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@ 145 extensions, a constraint cannot mention either of the last two type variables. For 146 example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot 147 have a derived 'Bifunctor' instance. 148 149* If either of the last two type variables is used within a constructor argument's 150 type, it must only be used in the last two type arguments. For example, 151 @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Bifunctor' instance, 152 but @data Illegal a b = Illegal (a, b, a, b)@ cannot. 153 154* Data family instances must be able to eta-reduce the last two type variables. In other 155 words, if you have a instance of the form: 156 157 @ 158 data family Family a1 ... an t1 t2 159 data instance Family e1 ... e2 v1 v2 = ... 160 @ 161 162 Then the following conditions must hold: 163 164 1. @v1@ and @v2@ must be distinct type variables. 165 2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@. 166 167-} 168 169{- $make 170 171There may be scenarios in which you want to, say, 'bimap' over an arbitrary data type 172or data family instance without having to make the type an instance of 'Bifunctor'. For 173these cases, this module provides several functions (all prefixed with @make@-) that 174splice the appropriate lambda expression into your source code. 175 176This is particularly useful for creating instances for sophisticated data types. For 177example, 'deriveBifunctor' cannot infer the correct type context for 178@newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind 179@* -> * -> * -> *@. However, it is still possible to create a 'Bifunctor' instance for 180@HigherKinded@ without too much trouble using 'makeBimap': 181 182@ 183{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} 184import Data.Bifunctor 185import Data.Bifunctor.TH 186 187newtype HigherKinded f a b c = HigherKinded (f a b c) 188 189instance Bifunctor (f a) => Bifunctor (HigherKinded f a) where 190 bimap = $(makeBimap ''HigherKinded) 191@ 192 193-} 194 195-- | Generates a 'Bifunctor' instance declaration for the given data type or data 196-- family instance. 197deriveBifunctor :: Name -> Q [Dec] 198deriveBifunctor = deriveBifunctorOptions defaultOptions 199 200-- | Like 'deriveBifunctor', but takes an 'Options' argument. 201deriveBifunctorOptions :: Options -> Name -> Q [Dec] 202deriveBifunctorOptions = deriveBiClass Bifunctor 203 204-- | Generates a lambda expression which behaves like 'bimap' (without requiring a 205-- 'Bifunctor' instance). 206makeBimap :: Name -> Q Exp 207makeBimap = makeBimapOptions defaultOptions 208 209-- | Like 'makeBimap', but takes an 'Options' argument. 210makeBimapOptions :: Options -> Name -> Q Exp 211makeBimapOptions = makeBiFun Bimap 212 213-- | Generates a 'Bifoldable' instance declaration for the given data type or data 214-- family instance. 215deriveBifoldable :: Name -> Q [Dec] 216deriveBifoldable = deriveBifoldableOptions defaultOptions 217 218-- | Like 'deriveBifoldable', but takes an 'Options' argument. 219deriveBifoldableOptions :: Options -> Name -> Q [Dec] 220deriveBifoldableOptions = deriveBiClass Bifoldable 221 222--- | Generates a lambda expression which behaves like 'bifold' (without requiring a 223-- 'Bifoldable' instance). 224makeBifold :: Name -> Q Exp 225makeBifold = makeBifoldOptions defaultOptions 226 227-- | Like 'makeBifold', but takes an 'Options' argument. 228makeBifoldOptions :: Options -> Name -> Q Exp 229makeBifoldOptions opts name = appsE [ makeBifoldMapOptions opts name 230 , varE idValName 231 , varE idValName 232 ] 233 234-- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring 235-- a 'Bifoldable' instance). 236makeBifoldMap :: Name -> Q Exp 237makeBifoldMap = makeBifoldMapOptions defaultOptions 238 239-- | Like 'makeBifoldMap', but takes an 'Options' argument. 240makeBifoldMapOptions :: Options -> Name -> Q Exp 241makeBifoldMapOptions = makeBiFun BifoldMap 242 243-- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a 244-- 'Bifoldable' instance). 245makeBifoldr :: Name -> Q Exp 246makeBifoldr = makeBifoldrOptions defaultOptions 247 248-- | Like 'makeBifoldr', but takes an 'Options' argument. 249makeBifoldrOptions :: Options -> Name -> Q Exp 250makeBifoldrOptions = makeBiFun Bifoldr 251 252-- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a 253-- 'Bifoldable' instance). 254makeBifoldl :: Name -> Q Exp 255makeBifoldl = makeBifoldlOptions defaultOptions 256 257-- | Like 'makeBifoldl', but takes an 'Options' argument. 258makeBifoldlOptions :: Options -> Name -> Q Exp 259makeBifoldlOptions opts name = do 260 f <- newName "f" 261 g <- newName "g" 262 z <- newName "z" 263 t <- newName "t" 264 lamE [varP f, varP g, varP z, varP t] $ 265 appsE [ varE appEndoValName 266 , appsE [ varE getDualValName 267 , appsE [ makeBifoldMapOptions opts name 268 , foldFun f 269 , foldFun g 270 , varE t] 271 ] 272 , varE z 273 ] 274 where 275 foldFun :: Name -> Q Exp 276 foldFun n = infixApp (conE dualDataName) 277 (varE composeValName) 278 (infixApp (conE endoDataName) 279 (varE composeValName) 280 (varE flipValName `appE` varE n) 281 ) 282 283-- | Generates a 'Bitraversable' instance declaration for the given data type or data 284-- family instance. 285deriveBitraversable :: Name -> Q [Dec] 286deriveBitraversable = deriveBitraversableOptions defaultOptions 287 288-- | Like 'deriveBitraversable', but takes an 'Options' argument. 289deriveBitraversableOptions :: Options -> Name -> Q [Dec] 290deriveBitraversableOptions = deriveBiClass Bitraversable 291 292-- | Generates a lambda expression which behaves like 'bitraverse' (without 293-- requiring a 'Bitraversable' instance). 294makeBitraverse :: Name -> Q Exp 295makeBitraverse = makeBitraverseOptions defaultOptions 296 297-- | Like 'makeBitraverse', but takes an 'Options' argument. 298makeBitraverseOptions :: Options -> Name -> Q Exp 299makeBitraverseOptions = makeBiFun Bitraverse 300 301-- | Generates a lambda expression which behaves like 'bisequenceA' (without 302-- requiring a 'Bitraversable' instance). 303makeBisequenceA :: Name -> Q Exp 304makeBisequenceA = makeBisequenceAOptions defaultOptions 305 306-- | Like 'makeBitraverseA', but takes an 'Options' argument. 307makeBisequenceAOptions :: Options -> Name -> Q Exp 308makeBisequenceAOptions opts name = appsE [ makeBitraverseOptions opts name 309 , varE idValName 310 , varE idValName 311 ] 312 313-- | Generates a lambda expression which behaves like 'bimapM' (without 314-- requiring a 'Bitraversable' instance). 315makeBimapM :: Name -> Q Exp 316makeBimapM = makeBimapMOptions defaultOptions 317 318-- | Like 'makeBimapM', but takes an 'Options' argument. 319makeBimapMOptions :: Options -> Name -> Q Exp 320makeBimapMOptions opts name = do 321 f <- newName "f" 322 g <- newName "g" 323 lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $ 324 appsE [ makeBitraverseOptions opts name 325 , wrapMonadExp f 326 , wrapMonadExp g 327 ] 328 where 329 wrapMonadExp :: Name -> Q Exp 330 wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) 331 332-- | Generates a lambda expression which behaves like 'bisequence' (without 333-- requiring a 'Bitraversable' instance). 334makeBisequence :: Name -> Q Exp 335makeBisequence = makeBisequenceOptions defaultOptions 336 337-- | Like 'makeBisequence', but takes an 'Options' argument. 338makeBisequenceOptions :: Options -> Name -> Q Exp 339makeBisequenceOptions opts name = appsE [ makeBimapMOptions opts name 340 , varE idValName 341 , varE idValName 342 ] 343 344------------------------------------------------------------------------------- 345-- Code generation 346------------------------------------------------------------------------------- 347 348-- | Derive a class instance declaration (depending on the BiClass argument's value). 349deriveBiClass :: BiClass -> Options -> Name -> Q [Dec] 350deriveBiClass biClass opts name = do 351 info <- reifyDatatype name 352 case info of 353 DatatypeInfo { datatypeContext = ctxt 354 , datatypeName = parentName 355 , datatypeInstTypes = instTys 356 , datatypeVariant = variant 357 , datatypeCons = cons 358 } -> do 359 (instanceCxt, instanceType) 360 <- buildTypeInstance biClass parentName ctxt instTys variant 361 (:[]) `fmap` instanceD (return instanceCxt) 362 (return instanceType) 363 (biFunDecs biClass opts parentName instTys cons) 364 365-- | Generates a declaration defining the primary function(s) corresponding to a 366-- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and 367-- bitraverse for Bitraversable). 368-- 369-- For why both bifoldr and bifoldMap are derived for Bifoldable, see Trac #7436. 370biFunDecs :: BiClass -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec] 371biFunDecs biClass opts parentName instTys cons = 372 map makeFunD $ biClassToFuns biClass 373 where 374 makeFunD :: BiFun -> Q Dec 375 makeFunD biFun = 376 funD (biFunName biFun) 377 [ clause [] 378 (normalB $ makeBiFunForCons biFun opts parentName instTys cons) 379 [] 380 ] 381 382-- | Generates a lambda expression which behaves like the BiFun argument. 383makeBiFun :: BiFun -> Options -> Name -> Q Exp 384makeBiFun biFun opts name = do 385 info <- reifyDatatype name 386 case info of 387 DatatypeInfo { datatypeContext = ctxt 388 , datatypeName = parentName 389 , datatypeInstTypes = instTys 390 , datatypeVariant = variant 391 , datatypeCons = cons 392 } -> 393 -- We force buildTypeInstance here since it performs some checks for whether 394 -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc. 395 -- implemented for it, and produces errors if it can't. 396 buildTypeInstance (biFunToClass biFun) parentName ctxt instTys variant 397 >> makeBiFunForCons biFun opts parentName instTys cons 398 399-- | Generates a lambda expression for the given constructors. 400-- All constructors must be from the same type. 401makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp 402makeBiFunForCons biFun opts _parentName instTys cons = do 403 argNames <- mapM newName $ catMaybes [ Just "f" 404 , Just "g" 405 , guard (biFun == Bifoldr) >> Just "z" 406 , Just "value" 407 ] 408 let ([map1, map2], others) = splitAt 2 argNames 409 z = head others -- If we're deriving bifoldr, this will be well defined 410 -- and useful. Otherwise, it'll be ignored. 411 value = last others 412 lastTyVars = map varTToName $ drop (length instTys - 2) instTys 413 tvMap = Map.fromList $ zip lastTyVars [map1, map2] 414 lamE (map varP argNames) 415 . appsE 416 $ [ varE $ biFunConstName biFun 417 , makeFun z value tvMap 418 ] ++ map varE argNames 419 where 420 makeFun :: Name -> Name -> TyVarMap -> Q Exp 421 makeFun z value tvMap = do 422#if MIN_VERSION_template_haskell(2,9,0) 423 roles <- reifyRoles _parentName 424#endif 425 case () of 426 _ 427 428#if MIN_VERSION_template_haskell(2,9,0) 429 | Just (rs, PhantomR) <- unsnoc roles 430 , Just (_, PhantomR) <- unsnoc rs 431 -> biFunPhantom z value 432#endif 433 434 | null cons && emptyCaseBehavior opts && ghc7'8OrLater 435 -> biFunEmptyCase biFun z value 436 437 | null cons 438 -> biFunNoCons biFun z value 439 440 | otherwise 441 -> caseE (varE value) 442 (map (makeBiFunForCon biFun z tvMap) cons) 443 444 ghc7'8OrLater :: Bool 445#if __GLASGOW_HASKELL__ >= 708 446 ghc7'8OrLater = True 447#else 448 ghc7'8OrLater = False 449#endif 450 451#if MIN_VERSION_template_haskell(2,9,0) 452 biFunPhantom :: Name -> Name -> Q Exp 453 biFunPhantom z value = 454 biFunTrivial coerce 455 (varE pureValName `appE` coerce) 456 biFun z 457 where 458 coerce :: Q Exp 459 coerce = varE coerceValName `appE` varE value 460#endif 461 462-- | Generates a lambda expression for a single constructor. 463makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match 464makeBiFunForCon biFun z tvMap 465 (ConstructorInfo { constructorName = conName 466 , constructorContext = ctxt 467 , constructorFields = ts }) = do 468 ts' <- mapM resolveTypeSynonyms ts 469 argNames <- newNameList "_arg" $ length ts' 470 if (any (`predMentionsName` Map.keys tvMap) ctxt 471 || Map.size tvMap < 2) 472 && not (allowExQuant (biFunToClass biFun)) 473 then existentialContextError conName 474 else makeBiFunForArgs biFun z tvMap conName ts' argNames 475 476-- | Generates a lambda expression for a single constructor's arguments. 477makeBiFunForArgs :: BiFun 478 -> Name 479 -> TyVarMap 480 -> Name 481 -> [Type] 482 -> [Name] 483 -> Q Match 484makeBiFunForArgs biFun z tvMap conName tys args = 485 match (conP conName $ map varP args) 486 (normalB $ biFunCombine biFun conName z args mappedArgs) 487 [] 488 where 489 mappedArgs :: Q [Either Exp Exp] 490 mappedArgs = zipWithM (makeBiFunForArg biFun tvMap conName) tys args 491 492-- | Generates a lambda expression for a single argument of a constructor. 493-- The returned value is 'Right' if its type mentions one of the last two type 494-- parameters. Otherwise, it is 'Left'. 495makeBiFunForArg :: BiFun 496 -> TyVarMap 497 -> Name 498 -> Type 499 -> Name 500 -> Q (Either Exp Exp) 501makeBiFunForArg biFun tvMap conName ty tyExpName = 502 makeBiFunForType biFun tvMap conName True ty `appEitherE` varE tyExpName 503 504-- | Generates a lambda expression for a specific type. The returned value is 505-- 'Right' if its type mentions one of the last two type parameters. Otherwise, 506-- it is 'Left'. 507makeBiFunForType :: BiFun 508 -> TyVarMap 509 -> Name 510 -> Bool 511 -> Type 512 -> Q (Either Exp Exp) 513makeBiFunForType biFun tvMap conName covariant (VarT tyName) = 514 case Map.lookup tyName tvMap of 515 Just mapName -> fmap Right . varE $ 516 if covariant 517 then mapName 518 else contravarianceError conName 519 Nothing -> fmap Left $ biFunTriv biFun 520makeBiFunForType biFun tvMap conName covariant (SigT ty _) = 521 makeBiFunForType biFun tvMap conName covariant ty 522makeBiFunForType biFun tvMap conName covariant (ForallT _ _ ty) = 523 makeBiFunForType biFun tvMap conName covariant ty 524makeBiFunForType biFun tvMap conName covariant ty = 525 let tyCon :: Type 526 tyArgs :: [Type] 527 tyCon:tyArgs = unapplyTy ty 528 529 numLastArgs :: Int 530 numLastArgs = min 2 $ length tyArgs 531 532 lhsArgs, rhsArgs :: [Type] 533 (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs 534 535 tyVarNames :: [Name] 536 tyVarNames = Map.keys tvMap 537 538 mentionsTyArgs :: Bool 539 mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs 540 541 makeBiFunTuple :: ([Q Pat] -> Q Pat) -> (Int -> Name) -> Int 542 -> Q (Either Exp Exp) 543 makeBiFunTuple mkTupP mkTupleDataName n = do 544 args <- mapM newName $ catMaybes [ Just "x" 545 , guard (biFun == Bifoldr) >> Just "z" 546 ] 547 xs <- newNameList "_tup" n 548 549 let x = head args 550 z = last args 551 fmap Right $ lamE (map varP args) $ caseE (varE x) 552 [ match (mkTupP $ map varP xs) 553 (normalB $ biFunCombine biFun 554 (mkTupleDataName n) 555 z 556 xs 557 (zipWithM makeBiFunTupleField tyArgs xs) 558 ) 559 [] 560 ] 561 562 makeBiFunTupleField :: Type -> Name -> Q (Either Exp Exp) 563 makeBiFunTupleField fieldTy fieldName = 564 makeBiFunForType biFun tvMap conName covariant fieldTy 565 `appEitherE` varE fieldName 566 567 in case tyCon of 568 ArrowT 569 | not (allowFunTys (biFunToClass biFun)) -> noFunctionsError conName 570 | mentionsTyArgs, [argTy, resTy] <- tyArgs -> 571 do x <- newName "x" 572 b <- newName "b" 573 fmap Right . lamE [varP x, varP b] $ 574 covBiFun covariant resTy `appE` (varE x `appE` 575 (covBiFun (not covariant) argTy `appE` varE b)) 576 where 577 covBiFun :: Bool -> Type -> Q Exp 578 covBiFun cov = fmap fromEither . makeBiFunForType biFun tvMap conName cov 579#if MIN_VERSION_template_haskell(2,6,0) 580 UnboxedTupleT n 581 | n > 0 && mentionsTyArgs -> makeBiFunTuple unboxedTupP unboxedTupleDataName n 582#endif 583 TupleT n 584 | n > 0 && mentionsTyArgs -> makeBiFunTuple tupP tupleDataName n 585 _ -> do 586 itf <- isTyFamily tyCon 587 if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs) 588 then outOfPlaceTyVarError conName 589 else if any (`mentionsName` tyVarNames) rhsArgs 590 then fmap Right . biFunApp biFun . appsE $ 591 ( varE (fromJust $ biFunArity biFun numLastArgs) 592 : map (fmap fromEither . makeBiFunForType biFun tvMap conName covariant) 593 rhsArgs 594 ) 595 else fmap Left $ biFunTriv biFun 596 597------------------------------------------------------------------------------- 598-- Template Haskell reifying and AST manipulation 599------------------------------------------------------------------------------- 600 601-- For the given Types, generate an instance context and head. Coming up with 602-- the instance type isn't as simple as dropping the last types, as you need to 603-- be wary of kinds being instantiated with *. 604-- See Note [Type inference in derived instances] 605buildTypeInstance :: BiClass 606 -- ^ Bifunctor, Bifoldable, or Bitraversable 607 -> Name 608 -- ^ The type constructor or data family name 609 -> Cxt 610 -- ^ The datatype context 611 -> [Type] 612 -- ^ The types to instantiate the instance with 613 -> DatatypeVariant 614 -- ^ Are we dealing with a data family instance or not 615 -> Q (Cxt, Type) 616buildTypeInstance biClass tyConName dataCxt instTysOrig variant = do 617 -- Make sure to expand through type/kind synonyms! Otherwise, the 618 -- eta-reduction check might get tripped up over type variables in a 619 -- synonym that are actually dropped. 620 -- (See GHC Trac #11416 for a scenario where this actually happened.) 621 varTysExp <- mapM resolveTypeSynonyms instTysOrig 622 623 let remainingLength :: Int 624 remainingLength = length instTysOrig - 2 625 626 droppedTysExp :: [Type] 627 droppedTysExp = drop remainingLength varTysExp 628 629 droppedStarKindStati :: [StarKindStatus] 630 droppedStarKindStati = map canRealizeKindStar droppedTysExp 631 632 -- Check there are enough types to drop and that all of them are either of 633 -- kind * or kind k (for some kind variable k). If not, throw an error. 634 when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ 635 derivingKindError biClass tyConName 636 637 let droppedKindVarNames :: [Name] 638 droppedKindVarNames = catKindVarNames droppedStarKindStati 639 640 -- Substitute kind * for any dropped kind variables 641 varTysExpSubst :: [Type] 642 varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp 643 644 remainingTysExpSubst, droppedTysExpSubst :: [Type] 645 (remainingTysExpSubst, droppedTysExpSubst) = 646 splitAt remainingLength varTysExpSubst 647 648 -- All of the type variables mentioned in the dropped types 649 -- (post-synonym expansion) 650 droppedTyVarNames :: [Name] 651 droppedTyVarNames = freeVariables droppedTysExpSubst 652 653 -- If any of the dropped types were polykinded, ensure that they are of kind * 654 -- after substituting * for the dropped kind variables. If not, throw an error. 655 unless (all hasKindStar droppedTysExpSubst) $ 656 derivingKindError biClass tyConName 657 658 let preds :: [Maybe Pred] 659 kvNames :: [[Name]] 660 kvNames' :: [Name] 661 -- Derive instance constraints (and any kind variables which are specialized 662 -- to * in those constraints) 663 (preds, kvNames) = unzip $ map (deriveConstraint biClass) remainingTysExpSubst 664 kvNames' = concat kvNames 665 666 -- Substitute the kind variables specialized in the constraints with * 667 remainingTysExpSubst' :: [Type] 668 remainingTysExpSubst' = 669 map (substNamesWithKindStar kvNames') remainingTysExpSubst 670 671 -- We now substitute all of the specialized-to-* kind variable names with 672 -- *, but in the original types, not the synonym-expanded types. The reason 673 -- we do this is a superficial one: we want the derived instance to resemble 674 -- the datatype written in source code as closely as possible. For example, 675 -- for the following data family instance: 676 -- 677 -- data family Fam a 678 -- newtype instance Fam String = Fam String 679 -- 680 -- We'd want to generate the instance: 681 -- 682 -- instance C (Fam String) 683 -- 684 -- Not: 685 -- 686 -- instance C (Fam [Char]) 687 remainingTysOrigSubst :: [Type] 688 remainingTysOrigSubst = 689 map (substNamesWithKindStar (union droppedKindVarNames kvNames')) 690 $ take remainingLength instTysOrig 691 692 isDataFamily :: Bool 693 isDataFamily = case variant of 694 Datatype -> False 695 Newtype -> False 696 DataInstance -> True 697 NewtypeInstance -> True 698 699 remainingTysOrigSubst' :: [Type] 700 -- See Note [Kind signatures in derived instances] for an explanation 701 -- of the isDataFamily check. 702 remainingTysOrigSubst' = 703 if isDataFamily 704 then remainingTysOrigSubst 705 else map unSigT remainingTysOrigSubst 706 707 instanceCxt :: Cxt 708 instanceCxt = catMaybes preds 709 710 instanceType :: Type 711 instanceType = AppT (ConT $ biClassName biClass) 712 $ applyTyCon tyConName remainingTysOrigSubst' 713 714 -- If the datatype context mentions any of the dropped type variables, 715 -- we can't derive an instance, so throw an error. 716 when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ 717 datatypeContextError tyConName instanceType 718 -- Also ensure the dropped types can be safely eta-reduced. Otherwise, 719 -- throw an error. 720 unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ 721 etaReductionError instanceType 722 return (instanceCxt, instanceType) 723 724-- | Attempt to derive a constraint on a Type. If successful, return 725-- Just the constraint and any kind variable names constrained to *. 726-- Otherwise, return Nothing and the empty list. 727-- 728-- See Note [Type inference in derived instances] for the heuristics used to 729-- come up with constraints. 730deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name]) 731deriveConstraint biClass t 732 | not (isTyVar t) = (Nothing, []) 733 | otherwise = case hasKindVarChain 1 t of 734 Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 1, ns) 735 _ -> case hasKindVarChain 2 t of 736 Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 2, ns) 737 _ -> (Nothing, []) 738 where 739 tName :: Name 740 tName = varTToName t 741 742{- 743Note [Kind signatures in derived instances] 744~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 745 746It is possible to put explicit kind signatures into the derived instances, e.g., 747 748 instance C a => C (Data (f :: * -> *)) where ... 749 750But it is preferable to avoid this if possible. If we come up with an incorrect 751kind signature (which is entirely possible, since our type inferencer is pretty 752unsophisticated - see Note [Type inference in derived instances]), then GHC will 753flat-out reject the instance, which is quite unfortunate. 754 755Plain old datatypes have the advantage that you can avoid using any kind signatures 756at all in their instances. This is because a datatype declaration uses all type 757variables, so the types that we use in a derived instance uniquely determine their 758kinds. As long as we plug in the right types, the kind inferencer can do the rest 759of the work. For this reason, we use unSigT to remove all kind signatures before 760splicing in the instance context and head. 761 762Data family instances are trickier, since a data family can have two instances that 763are distinguished by kind alone, e.g., 764 765 data family Fam (a :: k) 766 data instance Fam (a :: * -> *) 767 data instance Fam (a :: *) 768 769If we dropped the kind signatures for C (Fam a), then GHC will have no way of 770knowing which instance we are talking about. To avoid this scenario, we always 771include explicit kind signatures in data family instances. There is a chance that 772the inferred kind signatures will be incorrect, but if so, we can always fall back 773on the make- functions. 774 775Note [Type inference in derived instances] 776~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 777 778Type inference is can be tricky to get right, and we want to avoid recreating the 779entirety of GHC's type inferencer in Template Haskell. For this reason, we will 780probably never come up with derived instance contexts that are as accurate as 781GHC's. But that doesn't mean we can't do anything! There are a couple of simple 782things we can do to make instance contexts that work for 80% of use cases: 783 7841. If one of the last type parameters is polykinded, then its kind will be 785 specialized to * in the derived instance. We note what kind variable the type 786 parameter had and substitute it with * in the other types as well. For example, 787 imagine you had 788 789 data Data (a :: k) (b :: k) (c :: k) 790 791 Then you'd want to derived instance to be: 792 793 instance C (Data (a :: *)) 794 795 Not: 796 797 instance C (Data (a :: k)) 798 7992. We naïvely come up with instance constraints using the following criteria: 800 801 (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind 802 variables), then generate a Functor n constraint, and if k1/k2 are kind 803 variables, then substitute k1/k2 with * elsewhere in the types. We must 804 consider the case where they are kind variables because you might have a 805 scenario like this: 806 807 newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2) 808 = Compose (f (g a b)) 809 810 Which would have a derived Bifunctor instance of: 811 812 instance (Functor f, Bifunctor g) => Bifunctor (Compose f g) where ... 813 (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are 814 * or kind variables), then generate a Bifunctor n constraint and perform 815 kind substitution as in the other case. 816-} 817 818{- 819Note [Matching functions with GADT type variables] 820~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 821 822When deriving Bifoldable, there is a tricky corner case to consider: 823 824 data Both a b where 825 BothCon :: x -> x -> Both x x 826 827Which fold functions should be applied to which arguments of BothCon? We have a 828choice, since both the function of type (a -> m) and of type (b -> m) can be 829applied to either argument. In such a scenario, the second fold function takes 830precedence over the first fold function, so the derived Bifoldable instance would be: 831 832 instance Bifoldable Both where 833 bifoldMap _ g (BothCon x1 x2) = g x1 <> g x2 834 835This is not an arbitrary choice, as this definition ensures that 836bifoldMap id = Foldable.foldMap for a derived Bifoldable instance for Both. 837-} 838 839------------------------------------------------------------------------------- 840-- Error messages 841------------------------------------------------------------------------------- 842 843-- | Either the given data type doesn't have enough type variables, or one of 844-- the type variables to be eta-reduced cannot realize kind *. 845derivingKindError :: BiClass -> Name -> a 846derivingKindError biClass tyConName = error 847 . showString "Cannot derive well-kinded instance of form ‘" 848 . showString className 849 . showChar ' ' 850 . showParen True 851 ( showString (nameBase tyConName) 852 . showString " ..." 853 ) 854 . showString "‘\n\tClass " 855 . showString className 856 . showString " expects an argument of kind * -> * -> *" 857 $ "" 858 where 859 className :: String 860 className = nameBase $ biClassName biClass 861 862-- | One of the last two type variables appeard in a contravariant position 863-- when deriving Bifoldable or Bitraversable. 864contravarianceError :: Name -> a 865contravarianceError conName = error 866 . showString "Constructor ‘" 867 . showString (nameBase conName) 868 . showString "‘ must not use the last type variable(s) in a function argument" 869 $ "" 870 871-- | A constructor has a function argument in a derived Bifoldable or Bitraversable 872-- instance. 873noFunctionsError :: Name -> a 874noFunctionsError conName = error 875 . showString "Constructor ‘" 876 . showString (nameBase conName) 877 . showString "‘ must not contain function types" 878 $ "" 879 880-- | The data type has a DatatypeContext which mentions one of the eta-reduced 881-- type variables. 882datatypeContextError :: Name -> Type -> a 883datatypeContextError dataName instanceType = error 884 . showString "Can't make a derived instance of ‘" 885 . showString (pprint instanceType) 886 . showString "‘:\n\tData type ‘" 887 . showString (nameBase dataName) 888 . showString "‘ must not have a class context involving the last type argument(s)" 889 $ "" 890 891-- | The data type has an existential constraint which mentions one of the 892-- eta-reduced type variables. 893existentialContextError :: Name -> a 894existentialContextError conName = error 895 . showString "Constructor ‘" 896 . showString (nameBase conName) 897 . showString "‘ must be truly polymorphic in the last argument(s) of the data type" 898 $ "" 899 900-- | The data type mentions one of the n eta-reduced type variables in a place other 901-- than the last nth positions of a data type in a constructor's field. 902outOfPlaceTyVarError :: Name -> a 903outOfPlaceTyVarError conName = error 904 . showString "Constructor ‘" 905 . showString (nameBase conName) 906 . showString "‘ must only use its last two type variable(s) within" 907 . showString " the last two argument(s) of a data type" 908 $ "" 909 910-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce 911-- function for the criteria it would have to meet). 912etaReductionError :: Type -> a 913etaReductionError instanceType = error $ 914 "Cannot eta-reduce to an instance of form \n\tinstance (...) => " 915 ++ pprint instanceType 916 917------------------------------------------------------------------------------- 918-- Class-specific constants 919------------------------------------------------------------------------------- 920 921-- | A representation of which class is being derived. 922data BiClass = Bifunctor | Bifoldable | Bitraversable 923 924-- | A representation of which function is being generated. 925data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse 926 deriving Eq 927 928biFunConstName :: BiFun -> Name 929biFunConstName Bimap = bimapConstValName 930biFunConstName Bifoldr = bifoldrConstValName 931biFunConstName BifoldMap = bifoldMapConstValName 932biFunConstName Bitraverse = bitraverseConstValName 933 934biClassName :: BiClass -> Name 935biClassName Bifunctor = bifunctorTypeName 936biClassName Bifoldable = bifoldableTypeName 937biClassName Bitraversable = bitraversableTypeName 938 939biFunName :: BiFun -> Name 940biFunName Bimap = bimapValName 941biFunName Bifoldr = bifoldrValName 942biFunName BifoldMap = bifoldMapValName 943biFunName Bitraverse = bitraverseValName 944 945biClassToFuns :: BiClass -> [BiFun] 946biClassToFuns Bifunctor = [Bimap] 947biClassToFuns Bifoldable = [Bifoldr, BifoldMap] 948biClassToFuns Bitraversable = [Bitraverse] 949 950biFunToClass :: BiFun -> BiClass 951biFunToClass Bimap = Bifunctor 952biFunToClass Bifoldr = Bifoldable 953biFunToClass BifoldMap = Bifoldable 954biFunToClass Bitraverse = Bitraversable 955 956biClassConstraint :: BiClass -> Int -> Maybe Name 957biClassConstraint Bifunctor 1 = Just functorTypeName 958biClassConstraint Bifoldable 1 = Just foldableTypeName 959biClassConstraint Bitraversable 1 = Just traversableTypeName 960biClassConstraint biClass 2 = Just $ biClassName biClass 961biClassConstraint _ _ = Nothing 962 963biFunArity :: BiFun -> Int -> Maybe Name 964biFunArity Bimap 1 = Just fmapValName 965biFunArity Bifoldr 1 = Just foldrValName 966biFunArity BifoldMap 1 = Just foldMapValName 967biFunArity Bitraverse 1 = Just traverseValName 968biFunArity biFun 2 = Just $ biFunName biFun 969biFunArity _ _ = Nothing 970 971allowFunTys :: BiClass -> Bool 972allowFunTys Bifunctor = True 973allowFunTys _ = False 974 975allowExQuant :: BiClass -> Bool 976allowExQuant Bifoldable = True 977allowExQuant _ = False 978 979-- See Trac #7436 for why explicit lambdas are used 980biFunTriv :: BiFun -> Q Exp 981biFunTriv Bimap = do 982 x <- newName "x" 983 lamE [varP x] $ varE x 984-- The biFunTriv definitions for bifoldr, bifoldMap, and bitraverse might seem 985-- useless, but they do serve a purpose. 986-- See Note [biFunTriv for Bifoldable and Bitraversable] 987biFunTriv Bifoldr = do 988 z <- newName "z" 989 lamE [wildP, varP z] $ varE z 990biFunTriv BifoldMap = lamE [wildP] $ varE memptyValName 991biFunTriv Bitraverse = varE pureValName 992 993biFunApp :: BiFun -> Q Exp -> Q Exp 994biFunApp Bifoldr e = do 995 x <- newName "x" 996 z <- newName "z" 997 lamE [varP x, varP z] $ appsE [e, varE z, varE x] 998biFunApp _ e = e 999 1000biFunCombine :: BiFun 1001 -> Name 1002 -> Name 1003 -> [Name] 1004 -> Q [Either Exp Exp] 1005 -> Q Exp 1006biFunCombine Bimap = bimapCombine 1007biFunCombine Bifoldr = bifoldrCombine 1008biFunCombine BifoldMap = bifoldMapCombine 1009biFunCombine Bitraverse = bitraverseCombine 1010 1011bimapCombine :: Name 1012 -> Name 1013 -> [Name] 1014 -> Q [Either Exp Exp] 1015 -> Q Exp 1016bimapCombine conName _ _ = fmap (foldl' AppE (ConE conName) . fmap fromEither) 1017 1018-- bifoldr, bifoldMap, and bitraverse are handled differently from bimap, since 1019-- they filter out subexpressions whose types do not mention one of the last two 1020-- type parameters. See 1021-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable 1022-- for further discussion. 1023 1024bifoldrCombine :: Name 1025 -> Name 1026 -> [Name] 1027 -> Q [Either Exp Exp] 1028 -> Q Exp 1029bifoldrCombine _ zName _ = fmap (foldr AppE (VarE zName) . rights) 1030 1031bifoldMapCombine :: Name 1032 -> Name 1033 -> [Name] 1034 -> Q [Either Exp Exp] 1035 -> Q Exp 1036bifoldMapCombine _ _ _ = fmap (go . rights) 1037 where 1038 go :: [Exp] -> Exp 1039 go [] = VarE memptyValName 1040 go es = foldr1 (AppE . AppE (VarE mappendValName)) es 1041 1042bitraverseCombine :: Name 1043 -> Name 1044 -> [Name] 1045 -> Q [Either Exp Exp] 1046 -> Q Exp 1047bitraverseCombine conName _ args essQ = do 1048 ess <- essQ 1049 1050 let argTysTyVarInfo :: [Bool] 1051 argTysTyVarInfo = map isRight ess 1052 1053 argsWithTyVar, argsWithoutTyVar :: [Name] 1054 (argsWithTyVar, argsWithoutTyVar) = partitionByList argTysTyVarInfo args 1055 1056 conExpQ :: Q Exp 1057 conExpQ 1058 | null argsWithTyVar 1059 = appsE (conE conName:map varE argsWithoutTyVar) 1060 | otherwise = do 1061 bs <- newNameList "b" $ length args 1062 let bs' = filterByList argTysTyVarInfo bs 1063 vars = filterByLists argTysTyVarInfo 1064 (map varE bs) (map varE args) 1065 lamE (map varP bs') (appsE (conE conName:vars)) 1066 1067 conExp <- conExpQ 1068 1069 let go :: [Exp] -> Exp 1070 go [] = VarE pureValName `AppE` conExp 1071 go [e] = VarE fmapValName `AppE` conExp `AppE` e 1072 go (e1:e2:es) = foldl' (\se1 se2 -> InfixE (Just se1) (VarE apValName) (Just se2)) 1073 (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es 1074 1075 return . go . rights $ ess 1076 1077biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp 1078biFunEmptyCase biFun z value = 1079 biFunTrivial emptyCase 1080 (varE pureValName `appE` emptyCase) 1081 biFun z 1082 where 1083 emptyCase :: Q Exp 1084 emptyCase = caseE (varE value) [] 1085 1086biFunNoCons :: BiFun -> Name -> Name -> Q Exp 1087biFunNoCons biFun z value = 1088 biFunTrivial seqAndError 1089 (varE pureValName `appE` seqAndError) 1090 biFun z 1091 where 1092 seqAndError :: Q Exp 1093 seqAndError = appE (varE seqValName) (varE value) `appE` 1094 appE (varE errorValName) 1095 (stringE $ "Void " ++ nameBase (biFunName biFun)) 1096 1097biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp 1098biFunTrivial bimapE bitraverseE biFun z = go biFun 1099 where 1100 go :: BiFun -> Q Exp 1101 go Bimap = bimapE 1102 go Bifoldr = varE z 1103 go BifoldMap = varE memptyValName 1104 go Bitraverse = bitraverseE 1105 1106{- 1107Note [biFunTriv for Bifoldable and Bitraversable] 1108~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1109When deriving Bifoldable and Bitraversable, we filter out any subexpressions whose 1110type does not mention one of the last two type parameters. From this, you might 1111think that we don't need to implement biFunTriv for bifoldr, bifoldMap, or 1112bitraverse at all, but in fact we do need to. Imagine the following data type: 1113 1114 data T a b = MkT a (T Int b) 1115 1116In a derived Bifoldable T instance, you would generate the following bifoldMap 1117definition: 1118 1119 bifoldMap f g (MkT a1 a2) = f a1 <> bifoldMap (\_ -> mempty) g arg2 1120 1121You need to fill in biFunTriv (\_ -> mempty) as the first argument to the recursive 1122call to bifoldMap, since that is how the algorithm handles polymorphic recursion. 1123-} 1124