1{-# LANGUAGE CPP #-} 2{-# LANGUAGE BangPatterns #-} 3{-# LANGUAGE PatternGuards #-} 4{-# LANGUAGE ScopedTypeVariables #-} 5 6#if __GLASGOW_HASKELL__ >= 704 7{-# LANGUAGE Unsafe #-} 8#endif 9 10#ifndef MIN_VERSION_template_haskell 11#define MIN_VERSION_template_haskell(x,y,z) 1 12#endif 13----------------------------------------------------------------------------- 14-- | 15-- Copyright : (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott 16-- License : BSD-style (see the file LICENSE) 17-- 18-- Maintainer : Edward Kmett <ekmett@gmail.com> 19-- Stability : provisional 20-- Portability : portable 21-- 22-- Functions to mechanically derive 'Bifunctor', 'Bifoldable', 23-- or 'Bitraversable' instances, or to splice their functions directly into 24-- source code. You need to enable the @TemplateHaskell@ language extension 25-- in order to use this module. 26---------------------------------------------------------------------------- 27 28module Data.Bifunctor.TH ( 29 -- * @derive@- functions 30 -- $derive 31 -- * @make@- functions 32 -- $make 33 -- * 'Bifunctor' 34 deriveBifunctor 35 , deriveBifunctorOptions 36 , makeBimap 37 , makeBimapOptions 38 -- * 'Bifoldable' 39 , deriveBifoldable 40 , deriveBifoldableOptions 41 , makeBifold 42 , makeBifoldOptions 43 , makeBifoldMap 44 , makeBifoldMapOptions 45 , makeBifoldr 46 , makeBifoldrOptions 47 , makeBifoldl 48 , makeBifoldlOptions 49 -- * 'Bitraversable' 50 , deriveBitraversable 51 , deriveBitraversableOptions 52 , makeBitraverse 53 , makeBitraverseOptions 54 , makeBisequenceA 55 , makeBisequenceAOptions 56 , makeBimapM 57 , makeBimapMOptions 58 , makeBisequence 59 , makeBisequenceOptions 60 -- * 'Options' 61 , Options(..) 62 , defaultOptions 63 ) where 64 65import Control.Monad (guard, unless, when) 66 67import Data.Bifunctor.TH.Internal 68import qualified Data.List as List 69import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size) 70import Data.Maybe 71 72import Language.Haskell.TH.Datatype 73import Language.Haskell.TH.Datatype.TyVarBndr 74import Language.Haskell.TH.Lib 75import Language.Haskell.TH.Ppr 76import Language.Haskell.TH.Syntax 77 78------------------------------------------------------------------------------- 79-- User-facing API 80------------------------------------------------------------------------------- 81 82-- | Options that further configure how the functions in "Data.Bifunctor.TH" 83-- should behave. 84newtype Options = Options 85 { emptyCaseBehavior :: Bool 86 -- ^ If 'True', derived instances for empty data types (i.e., ones with 87 -- no data constructors) will use the @EmptyCase@ language extension. 88 -- If 'False', derived instances will simply use 'seq' instead. 89 -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only 90 -- available in 7.8 or later.) 91 } deriving (Eq, Ord, Read, Show) 92 93-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to 94-- prevent users from having to enable that extension at use sites.) 95defaultOptions :: Options 96defaultOptions = Options { emptyCaseBehavior = False } 97 98{- $derive 99 100'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically 101generate their respective class instances for a given data type, newtype, or data 102family instance that has at least two type variable. Examples: 103 104@ 105{-# LANGUAGE TemplateHaskell #-} 106import Data.Bifunctor.TH 107 108data Pair a b = Pair a b 109$('deriveBifunctor' ''Pair) -- instance Bifunctor Pair where ... 110 111data WrapLeftPair f g a b = WrapLeftPair (f a) (g a b) 112$('deriveBifoldable' ''WrapLeftPair) 113-- instance (Foldable f, Bifoldable g) => Bifoldable (WrapLeftPair f g) where ... 114@ 115 116If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later), 117the @derive@ functions can be used data family instances (which requires the 118@-XTypeFamilies@ extension). To do so, pass the name of a data or newtype instance 119constructor (NOT a data family name!) to a @derive@ function. Note that the 120generated code may require the @-XFlexibleInstances@ extension. Example: 121 122@ 123{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} 124import Data.Bifunctor.TH 125 126class AssocClass a b c where 127 data AssocData a b c 128instance AssocClass Int b c where 129 data AssocData Int b c = AssocDataInt1 Int | AssocDataInt2 b c 130$('deriveBitraversable' 'AssocDataInt1) -- instance Bitraversable (AssocData Int) where ... 131-- Alternatively, one could use $(deriveBitraversable 'AssocDataInt2) 132@ 133 134Note that there are some limitations: 135 136* The 'Name' argument to a @derive@ function must not be a type synonym. 137 138* With a @derive@ function, the last two type variables must both be of kind @*@. 139 Other type variables of kind @* -> *@ are assumed to require a 'Functor', 140 'Foldable', or 'Traversable' constraint (depending on which @derive@ function is 141 used), and other type variables of kind @* -> * -> *@ are assumed to require an 142 'Bifunctor', 'Bifoldable', or 'Bitraversable' constraint. If your data type 143 doesn't meet these assumptions, use a @make@ function. 144 145* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@ 146 extensions, a constraint cannot mention either of the last two type variables. For 147 example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot 148 have a derived 'Bifunctor' instance. 149 150* If either of the last two type variables is used within a constructor argument's 151 type, it must only be used in the last two type arguments. For example, 152 @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Bifunctor' instance, 153 but @data Illegal a b = Illegal (a, b, a, b)@ cannot. 154 155* Data family instances must be able to eta-reduce the last two type variables. In other 156 words, if you have a instance of the form: 157 158 @ 159 data family Family a1 ... an t1 t2 160 data instance Family e1 ... e2 v1 v2 = ... 161 @ 162 163 Then the following conditions must hold: 164 165 1. @v1@ and @v2@ must be distinct type variables. 166 2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@. 167 168-} 169 170{- $make 171 172There may be scenarios in which you want to, say, 'bimap' over an arbitrary data type 173or data family instance without having to make the type an instance of 'Bifunctor'. For 174these cases, this module provides several functions (all prefixed with @make@-) that 175splice the appropriate lambda expression into your source code. 176 177This is particularly useful for creating instances for sophisticated data types. For 178example, 'deriveBifunctor' cannot infer the correct type context for 179@newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind 180@* -> * -> * -> *@. However, it is still possible to create a 'Bifunctor' instance for 181@HigherKinded@ without too much trouble using 'makeBimap': 182 183@ 184{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} 185import Data.Bifunctor 186import Data.Bifunctor.TH 187 188newtype HigherKinded f a b c = HigherKinded (f a b c) 189 190instance Bifunctor (f a) => Bifunctor (HigherKinded f a) where 191 bimap = $(makeBimap ''HigherKinded) 192@ 193 194-} 195 196-- | Generates a 'Bifunctor' instance declaration for the given data type or data 197-- family instance. 198deriveBifunctor :: Name -> Q [Dec] 199deriveBifunctor = deriveBifunctorOptions defaultOptions 200 201-- | Like 'deriveBifunctor', but takes an 'Options' argument. 202deriveBifunctorOptions :: Options -> Name -> Q [Dec] 203deriveBifunctorOptions = deriveBiClass Bifunctor 204 205-- | Generates a lambda expression which behaves like 'bimap' (without requiring a 206-- 'Bifunctor' instance). 207makeBimap :: Name -> Q Exp 208makeBimap = makeBimapOptions defaultOptions 209 210-- | Like 'makeBimap', but takes an 'Options' argument. 211makeBimapOptions :: Options -> Name -> Q Exp 212makeBimapOptions = makeBiFun Bimap 213 214-- | Generates a 'Bifoldable' instance declaration for the given data type or data 215-- family instance. 216deriveBifoldable :: Name -> Q [Dec] 217deriveBifoldable = deriveBifoldableOptions defaultOptions 218 219-- | Like 'deriveBifoldable', but takes an 'Options' argument. 220deriveBifoldableOptions :: Options -> Name -> Q [Dec] 221deriveBifoldableOptions = deriveBiClass Bifoldable 222 223--- | Generates a lambda expression which behaves like 'bifold' (without requiring a 224-- 'Bifoldable' instance). 225makeBifold :: Name -> Q Exp 226makeBifold = makeBifoldOptions defaultOptions 227 228-- | Like 'makeBifold', but takes an 'Options' argument. 229makeBifoldOptions :: Options -> Name -> Q Exp 230makeBifoldOptions opts name = appsE [ makeBifoldMapOptions opts name 231 , varE idValName 232 , varE idValName 233 ] 234 235-- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring 236-- a 'Bifoldable' instance). 237makeBifoldMap :: Name -> Q Exp 238makeBifoldMap = makeBifoldMapOptions defaultOptions 239 240-- | Like 'makeBifoldMap', but takes an 'Options' argument. 241makeBifoldMapOptions :: Options -> Name -> Q Exp 242makeBifoldMapOptions = makeBiFun BifoldMap 243 244-- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a 245-- 'Bifoldable' instance). 246makeBifoldr :: Name -> Q Exp 247makeBifoldr = makeBifoldrOptions defaultOptions 248 249-- | Like 'makeBifoldr', but takes an 'Options' argument. 250makeBifoldrOptions :: Options -> Name -> Q Exp 251makeBifoldrOptions = makeBiFun Bifoldr 252 253-- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a 254-- 'Bifoldable' instance). 255makeBifoldl :: Name -> Q Exp 256makeBifoldl = makeBifoldlOptions defaultOptions 257 258-- | Like 'makeBifoldl', but takes an 'Options' argument. 259makeBifoldlOptions :: Options -> Name -> Q Exp 260makeBifoldlOptions opts name = do 261 f <- newName "f" 262 g <- newName "g" 263 z <- newName "z" 264 t <- newName "t" 265 lamE [varP f, varP g, varP z, varP t] $ 266 appsE [ varE appEndoValName 267 , appsE [ varE getDualValName 268 , appsE [ makeBifoldMapOptions opts name 269 , foldFun f 270 , foldFun g 271 , varE t] 272 ] 273 , varE z 274 ] 275 where 276 foldFun :: Name -> Q Exp 277 foldFun n = infixApp (conE dualDataName) 278 (varE composeValName) 279 (infixApp (conE endoDataName) 280 (varE composeValName) 281 (varE flipValName `appE` varE n) 282 ) 283 284-- | Generates a 'Bitraversable' instance declaration for the given data type or data 285-- family instance. 286deriveBitraversable :: Name -> Q [Dec] 287deriveBitraversable = deriveBitraversableOptions defaultOptions 288 289-- | Like 'deriveBitraversable', but takes an 'Options' argument. 290deriveBitraversableOptions :: Options -> Name -> Q [Dec] 291deriveBitraversableOptions = deriveBiClass Bitraversable 292 293-- | Generates a lambda expression which behaves like 'bitraverse' (without 294-- requiring a 'Bitraversable' instance). 295makeBitraverse :: Name -> Q Exp 296makeBitraverse = makeBitraverseOptions defaultOptions 297 298-- | Like 'makeBitraverse', but takes an 'Options' argument. 299makeBitraverseOptions :: Options -> Name -> Q Exp 300makeBitraverseOptions = makeBiFun Bitraverse 301 302-- | Generates a lambda expression which behaves like 'bisequenceA' (without 303-- requiring a 'Bitraversable' instance). 304makeBisequenceA :: Name -> Q Exp 305makeBisequenceA = makeBisequenceAOptions defaultOptions 306 307-- | Like 'makeBitraverseA', but takes an 'Options' argument. 308makeBisequenceAOptions :: Options -> Name -> Q Exp 309makeBisequenceAOptions opts name = appsE [ makeBitraverseOptions opts name 310 , varE idValName 311 , varE idValName 312 ] 313 314-- | Generates a lambda expression which behaves like 'bimapM' (without 315-- requiring a 'Bitraversable' instance). 316makeBimapM :: Name -> Q Exp 317makeBimapM = makeBimapMOptions defaultOptions 318 319-- | Like 'makeBimapM', but takes an 'Options' argument. 320makeBimapMOptions :: Options -> Name -> Q Exp 321makeBimapMOptions opts name = do 322 f <- newName "f" 323 g <- newName "g" 324 lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $ 325 appsE [ makeBitraverseOptions opts name 326 , wrapMonadExp f 327 , wrapMonadExp g 328 ] 329 where 330 wrapMonadExp :: Name -> Q Exp 331 wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) 332 333-- | Generates a lambda expression which behaves like 'bisequence' (without 334-- requiring a 'Bitraversable' instance). 335makeBisequence :: Name -> Q Exp 336makeBisequence = makeBisequenceOptions defaultOptions 337 338-- | Like 'makeBisequence', but takes an 'Options' argument. 339makeBisequenceOptions :: Options -> Name -> Q Exp 340makeBisequenceOptions opts name = appsE [ makeBimapMOptions opts name 341 , varE idValName 342 , varE idValName 343 ] 344 345------------------------------------------------------------------------------- 346-- Code generation 347------------------------------------------------------------------------------- 348 349-- | Derive a class instance declaration (depending on the BiClass argument's value). 350deriveBiClass :: BiClass -> Options -> Name -> Q [Dec] 351deriveBiClass biClass opts name = do 352 info <- reifyDatatype name 353 case info of 354 DatatypeInfo { datatypeContext = ctxt 355 , datatypeName = parentName 356 , datatypeInstTypes = instTys 357 , datatypeVariant = variant 358 , datatypeCons = cons 359 } -> do 360 (instanceCxt, instanceType) 361 <- buildTypeInstance biClass parentName ctxt instTys variant 362 (:[]) `fmap` instanceD (return instanceCxt) 363 (return instanceType) 364 (biFunDecs biClass opts parentName instTys cons) 365 366-- | Generates a declaration defining the primary function(s) corresponding to a 367-- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and 368-- bitraverse for Bitraversable). 369-- 370-- For why both bifoldr and bifoldMap are derived for Bifoldable, see Trac #7436. 371biFunDecs :: BiClass -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec] 372biFunDecs biClass opts parentName instTys cons = 373 map makeFunD $ biClassToFuns biClass 374 where 375 makeFunD :: BiFun -> Q Dec 376 makeFunD biFun = 377 funD (biFunName biFun) 378 [ clause [] 379 (normalB $ makeBiFunForCons biFun opts parentName instTys cons) 380 [] 381 ] 382 383-- | Generates a lambda expression which behaves like the BiFun argument. 384makeBiFun :: BiFun -> Options -> Name -> Q Exp 385makeBiFun biFun opts name = do 386 info <- reifyDatatype name 387 case info of 388 DatatypeInfo { datatypeContext = ctxt 389 , datatypeName = parentName 390 , datatypeInstTypes = instTys 391 , datatypeVariant = variant 392 , datatypeCons = cons 393 } -> 394 -- We force buildTypeInstance here since it performs some checks for whether 395 -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc. 396 -- implemented for it, and produces errors if it can't. 397 buildTypeInstance (biFunToClass biFun) parentName ctxt instTys variant 398 >> makeBiFunForCons biFun opts parentName instTys cons 399 400-- | Generates a lambda expression for the given constructors. 401-- All constructors must be from the same type. 402makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp 403makeBiFunForCons biFun opts _parentName instTys cons = do 404 map1 <- newName "f" 405 map2 <- newName "g" 406 z <- newName "z" -- Only used for deriving bifoldr 407 value <- newName "value" 408 let argNames = catMaybes [ Just map1 409 , Just map2 410 , guard (biFun == Bifoldr) >> Just z 411 , Just value 412 ] 413 lastTyVars = map varTToName $ drop (length instTys - 2) instTys 414 tvMap = Map.fromList $ zip lastTyVars [map1, map2] 415 lamE (map varP argNames) 416 . appsE 417 $ [ varE $ biFunConstName biFun 418 , makeFun z value tvMap 419 ] ++ map varE argNames 420 where 421 makeFun :: Name -> Name -> TyVarMap -> Q Exp 422 makeFun z value tvMap = do 423#if MIN_VERSION_template_haskell(2,9,0) 424 roles <- reifyRoles _parentName 425#endif 426 case () of 427 _ 428 429#if MIN_VERSION_template_haskell(2,9,0) 430 | Just (rs, PhantomR) <- unsnoc roles 431 , Just (_, PhantomR) <- unsnoc rs 432 -> biFunPhantom z value 433#endif 434 435 | null cons && emptyCaseBehavior opts && ghc7'8OrLater 436 -> biFunEmptyCase biFun z value 437 438 | null cons 439 -> biFunNoCons biFun z value 440 441 | otherwise 442 -> caseE (varE value) 443 (map (makeBiFunForCon biFun z tvMap) cons) 444 445 ghc7'8OrLater :: Bool 446#if __GLASGOW_HASKELL__ >= 708 447 ghc7'8OrLater = True 448#else 449 ghc7'8OrLater = False 450#endif 451 452#if MIN_VERSION_template_haskell(2,9,0) 453 biFunPhantom :: Name -> Name -> Q Exp 454 biFunPhantom z value = 455 biFunTrivial coerce 456 (varE pureValName `appE` coerce) 457 biFun z 458 where 459 coerce :: Q Exp 460 coerce = varE coerceValName `appE` varE value 461#endif 462 463-- | Generates a match for a single constructor. 464makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match 465makeBiFunForCon biFun z tvMap 466 con@(ConstructorInfo { constructorName = conName 467 , constructorContext = ctxt }) = do 468 when ((any (`predMentionsName` Map.keys tvMap) ctxt 469 || Map.size tvMap < 2) 470 && not (allowExQuant (biFunToClass biFun))) $ 471 existentialContextError conName 472 case biFun of 473 Bimap -> makeBimapMatch tvMap con 474 Bifoldr -> makeBifoldrMatch z tvMap con 475 BifoldMap -> makeBifoldMapMatch tvMap con 476 Bitraverse -> makeBitraverseMatch tvMap con 477 478-- | Generates a match whose right-hand side implements @bimap@. 479makeBimapMatch :: TyVarMap -> ConstructorInfo -> Q Match 480makeBimapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do 481 parts <- foldDataConArgs tvMap ft_bimap con 482 match_for_con conName parts 483 where 484 ft_bimap :: FFoldType (Exp -> Q Exp) 485 ft_bimap = FT { ft_triv = return 486 , ft_var = \v x -> return $ VarE (tvMap Map.! v) `AppE` x 487 , ft_fun = \g h x -> mkSimpleLam $ \b -> do 488 gg <- g b 489 h $ x `AppE` gg 490 , ft_tup = mkSimpleTupleCase match_for_con 491 , ft_ty_app = \argGs x -> do 492 let inspect :: (Type, Exp -> Q Exp) -> Q Exp 493 inspect (argTy, g) 494 -- If the argument type is a bare occurrence of one 495 -- of the data type's last type variables, then we 496 -- can generate more efficient code. 497 -- This was inspired by GHC#17880. 498 | Just argVar <- varTToName_maybe argTy 499 , Just f <- Map.lookup argVar tvMap 500 = return $ VarE f 501 | otherwise 502 = mkSimpleLam g 503 appsE $ varE (fmapArity (length argGs)) 504 : map inspect argGs 505 ++ [return x] 506 , ft_forall = \_ g x -> g x 507 , ft_bad_app = \_ -> outOfPlaceTyVarError conName 508 , ft_co_var = \_ _ -> contravarianceError conName 509 } 510 511 -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... 512 match_for_con :: Name -> [Exp -> Q Exp] -> Q Match 513 match_for_con = mkSimpleConMatch $ \conName' xs -> 514 appsE (conE conName':xs) -- Con x1 x2 .. 515 516-- | Generates a match whose right-hand side implements @bifoldr@. 517makeBifoldrMatch :: Name -> TyVarMap -> ConstructorInfo -> Q Match 518makeBifoldrMatch z tvMap con@(ConstructorInfo{constructorName = conName}) = do 519 parts <- foldDataConArgs tvMap ft_bifoldr con 520 parts' <- sequence parts 521 match_for_con (VarE z) conName parts' 522 where 523 -- The Bool is True if the type mentions of the last two type parameters, 524 -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter 525 -- out expressions that do not mention the last parameters by checking for 526 -- False. 527 ft_bifoldr :: FFoldType (Q (Bool, Exp)) 528 ft_bifoldr = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] 529 ft_triv = do lam <- mkSimpleLam2 $ \_ z' -> return z' 530 return (False, lam) 531 , ft_var = \v -> return (True, VarE $ tvMap Map.! v) 532 , ft_tup = \t gs -> do 533 gg <- sequence gs 534 lam <- mkSimpleLam2 $ \x z' -> 535 mkSimpleTupleCase (match_for_con z') t gg x 536 return (True, lam) 537 , ft_ty_app = \gs -> do 538 lam <- mkSimpleLam2 $ \x z' -> 539 appsE $ varE (foldrArity (length gs)) 540 : map (\(_, hs) -> fmap snd hs) gs 541 ++ map return [z', x] 542 return (True, lam) 543 , ft_forall = \_ g -> g 544 , ft_co_var = \_ -> contravarianceError conName 545 , ft_fun = \_ _ -> noFunctionsError conName 546 , ft_bad_app = outOfPlaceTyVarError conName 547 } 548 549 match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match 550 match_for_con zExp = mkSimpleConMatch2 $ \_ xs -> return $ mkBifoldr xs 551 where 552 -- g1 v1 (g2 v2 (.. z)) 553 mkBifoldr :: [Exp] -> Exp 554 mkBifoldr = foldr AppE zExp 555 556-- | Generates a match whose right-hand side implements @bifoldMap@. 557makeBifoldMapMatch :: TyVarMap -> ConstructorInfo -> Q Match 558makeBifoldMapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do 559 parts <- foldDataConArgs tvMap ft_bifoldMap con 560 parts' <- sequence parts 561 match_for_con conName parts' 562 where 563 -- The Bool is True if the type mentions of the last two type parameters, 564 -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter 565 -- out expressions that do not mention the last parameters by checking for 566 -- False. 567 ft_bifoldMap :: FFoldType (Q (Bool, Exp)) 568 ft_bifoldMap = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] 569 ft_triv = do lam <- mkSimpleLam $ \_ -> return $ VarE memptyValName 570 return (False, lam) 571 , ft_var = \v -> return (True, VarE $ tvMap Map.! v) 572 , ft_tup = \t gs -> do 573 gg <- sequence gs 574 lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg 575 return (True, lam) 576 , ft_ty_app = \gs -> do 577 e <- appsE $ varE (foldMapArity (length gs)) 578 : map (\(_, hs) -> fmap snd hs) gs 579 return (True, e) 580 , ft_forall = \_ g -> g 581 , ft_co_var = \_ -> contravarianceError conName 582 , ft_fun = \_ _ -> noFunctionsError conName 583 , ft_bad_app = outOfPlaceTyVarError conName 584 } 585 586 match_for_con :: Name -> [(Bool, Exp)] -> Q Match 587 match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkBifoldMap xs 588 where 589 -- mappend v1 (mappend v2 ..) 590 mkBifoldMap :: [Exp] -> Exp 591 mkBifoldMap [] = VarE memptyValName 592 mkBifoldMap es = foldr1 (AppE . AppE (VarE mappendValName)) es 593 594-- | Generates a match whose right-hand side implements @bitraverse@. 595makeBitraverseMatch :: TyVarMap -> ConstructorInfo -> Q Match 596makeBitraverseMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do 597 parts <- foldDataConArgs tvMap ft_bitrav con 598 parts' <- sequence parts 599 match_for_con conName parts' 600 where 601 -- The Bool is True if the type mentions of the last two type parameters, 602 -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter 603 -- out expressions that do not mention the last parameters by checking for 604 -- False. 605 ft_bitrav :: FFoldType (Q (Bool, Exp)) 606 ft_bitrav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] 607 ft_triv = return (False, VarE pureValName) 608 , ft_var = \v -> return (True, VarE $ tvMap Map.! v) 609 , ft_tup = \t gs -> do 610 gg <- sequence gs 611 lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg 612 return (True, lam) 613 , ft_ty_app = \gs -> do 614 e <- appsE $ varE (traverseArity (length gs)) 615 : map (\(_, hs) -> fmap snd hs) gs 616 return (True, e) 617 , ft_forall = \_ g -> g 618 , ft_co_var = \_ -> contravarianceError conName 619 , ft_fun = \_ _ -> noFunctionsError conName 620 , ft_bad_app = outOfPlaceTyVarError conName 621 } 622 623 -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) 624 -- (g2 a2) <*> ... 625 match_for_con :: Name -> [(Bool, Exp)] -> Q Match 626 match_for_con = mkSimpleConMatch2 $ \conExp xs -> return $ mkApCon conExp xs 627 where 628 -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. 629 mkApCon :: Exp -> [Exp] -> Exp 630 mkApCon conExp [] = VarE pureValName `AppE` conExp 631 mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e 632 mkApCon conExp (e1:e2:es) = List.foldl' appAp 633 (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es 634 where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2) 635 636------------------------------------------------------------------------------- 637-- Template Haskell reifying and AST manipulation 638------------------------------------------------------------------------------- 639 640-- For the given Types, generate an instance context and head. Coming up with 641-- the instance type isn't as simple as dropping the last types, as you need to 642-- be wary of kinds being instantiated with *. 643-- See Note [Type inference in derived instances] 644buildTypeInstance :: BiClass 645 -- ^ Bifunctor, Bifoldable, or Bitraversable 646 -> Name 647 -- ^ The type constructor or data family name 648 -> Cxt 649 -- ^ The datatype context 650 -> [Type] 651 -- ^ The types to instantiate the instance with 652 -> DatatypeVariant 653 -- ^ Are we dealing with a data family instance or not 654 -> Q (Cxt, Type) 655buildTypeInstance biClass tyConName dataCxt instTysOrig variant = do 656 -- Make sure to expand through type/kind synonyms! Otherwise, the 657 -- eta-reduction check might get tripped up over type variables in a 658 -- synonym that are actually dropped. 659 -- (See GHC Trac #11416 for a scenario where this actually happened.) 660 varTysExp <- mapM resolveTypeSynonyms instTysOrig 661 662 let remainingLength :: Int 663 remainingLength = length instTysOrig - 2 664 665 droppedTysExp :: [Type] 666 droppedTysExp = drop remainingLength varTysExp 667 668 droppedStarKindStati :: [StarKindStatus] 669 droppedStarKindStati = map canRealizeKindStar droppedTysExp 670 671 -- Check there are enough types to drop and that all of them are either of 672 -- kind * or kind k (for some kind variable k). If not, throw an error. 673 when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ 674 derivingKindError biClass tyConName 675 676 let droppedKindVarNames :: [Name] 677 droppedKindVarNames = catKindVarNames droppedStarKindStati 678 679 -- Substitute kind * for any dropped kind variables 680 varTysExpSubst :: [Type] 681 varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp 682 683 remainingTysExpSubst, droppedTysExpSubst :: [Type] 684 (remainingTysExpSubst, droppedTysExpSubst) = 685 splitAt remainingLength varTysExpSubst 686 687 -- All of the type variables mentioned in the dropped types 688 -- (post-synonym expansion) 689 droppedTyVarNames :: [Name] 690 droppedTyVarNames = freeVariables droppedTysExpSubst 691 692 -- If any of the dropped types were polykinded, ensure that they are of kind * 693 -- after substituting * for the dropped kind variables. If not, throw an error. 694 unless (all hasKindStar droppedTysExpSubst) $ 695 derivingKindError biClass tyConName 696 697 let preds :: [Maybe Pred] 698 kvNames :: [[Name]] 699 kvNames' :: [Name] 700 -- Derive instance constraints (and any kind variables which are specialized 701 -- to * in those constraints) 702 (preds, kvNames) = unzip $ map (deriveConstraint biClass) remainingTysExpSubst 703 kvNames' = concat kvNames 704 705 -- Substitute the kind variables specialized in the constraints with * 706 remainingTysExpSubst' :: [Type] 707 remainingTysExpSubst' = 708 map (substNamesWithKindStar kvNames') remainingTysExpSubst 709 710 -- We now substitute all of the specialized-to-* kind variable names with 711 -- *, but in the original types, not the synonym-expanded types. The reason 712 -- we do this is a superficial one: we want the derived instance to resemble 713 -- the datatype written in source code as closely as possible. For example, 714 -- for the following data family instance: 715 -- 716 -- data family Fam a 717 -- newtype instance Fam String = Fam String 718 -- 719 -- We'd want to generate the instance: 720 -- 721 -- instance C (Fam String) 722 -- 723 -- Not: 724 -- 725 -- instance C (Fam [Char]) 726 remainingTysOrigSubst :: [Type] 727 remainingTysOrigSubst = 728 map (substNamesWithKindStar (List.union droppedKindVarNames kvNames')) 729 $ take remainingLength instTysOrig 730 731 isDataFamily :: Bool 732 isDataFamily = case variant of 733 Datatype -> False 734 Newtype -> False 735 DataInstance -> True 736 NewtypeInstance -> True 737 738 remainingTysOrigSubst' :: [Type] 739 -- See Note [Kind signatures in derived instances] for an explanation 740 -- of the isDataFamily check. 741 remainingTysOrigSubst' = 742 if isDataFamily 743 then remainingTysOrigSubst 744 else map unSigT remainingTysOrigSubst 745 746 instanceCxt :: Cxt 747 instanceCxt = catMaybes preds 748 749 instanceType :: Type 750 instanceType = AppT (ConT $ biClassName biClass) 751 $ applyTyCon tyConName remainingTysOrigSubst' 752 753 -- If the datatype context mentions any of the dropped type variables, 754 -- we can't derive an instance, so throw an error. 755 when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ 756 datatypeContextError tyConName instanceType 757 -- Also ensure the dropped types can be safely eta-reduced. Otherwise, 758 -- throw an error. 759 unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ 760 etaReductionError instanceType 761 return (instanceCxt, instanceType) 762 763-- | Attempt to derive a constraint on a Type. If successful, return 764-- Just the constraint and any kind variable names constrained to *. 765-- Otherwise, return Nothing and the empty list. 766-- 767-- See Note [Type inference in derived instances] for the heuristics used to 768-- come up with constraints. 769deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name]) 770deriveConstraint biClass t 771 | not (isTyVar t) = (Nothing, []) 772 | otherwise = case hasKindVarChain 1 t of 773 Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 1, ns) 774 _ -> case hasKindVarChain 2 t of 775 Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 2, ns) 776 _ -> (Nothing, []) 777 where 778 tName :: Name 779 tName = varTToName t 780 781{- 782Note [Kind signatures in derived instances] 783~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 784 785It is possible to put explicit kind signatures into the derived instances, e.g., 786 787 instance C a => C (Data (f :: * -> *)) where ... 788 789But it is preferable to avoid this if possible. If we come up with an incorrect 790kind signature (which is entirely possible, since our type inferencer is pretty 791unsophisticated - see Note [Type inference in derived instances]), then GHC will 792flat-out reject the instance, which is quite unfortunate. 793 794Plain old datatypes have the advantage that you can avoid using any kind signatures 795at all in their instances. This is because a datatype declaration uses all type 796variables, so the types that we use in a derived instance uniquely determine their 797kinds. As long as we plug in the right types, the kind inferencer can do the rest 798of the work. For this reason, we use unSigT to remove all kind signatures before 799splicing in the instance context and head. 800 801Data family instances are trickier, since a data family can have two instances that 802are distinguished by kind alone, e.g., 803 804 data family Fam (a :: k) 805 data instance Fam (a :: * -> *) 806 data instance Fam (a :: *) 807 808If we dropped the kind signatures for C (Fam a), then GHC will have no way of 809knowing which instance we are talking about. To avoid this scenario, we always 810include explicit kind signatures in data family instances. There is a chance that 811the inferred kind signatures will be incorrect, but if so, we can always fall back 812on the make- functions. 813 814Note [Type inference in derived instances] 815~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 816 817Type inference is can be tricky to get right, and we want to avoid recreating the 818entirety of GHC's type inferencer in Template Haskell. For this reason, we will 819probably never come up with derived instance contexts that are as accurate as 820GHC's. But that doesn't mean we can't do anything! There are a couple of simple 821things we can do to make instance contexts that work for 80% of use cases: 822 8231. If one of the last type parameters is polykinded, then its kind will be 824 specialized to * in the derived instance. We note what kind variable the type 825 parameter had and substitute it with * in the other types as well. For example, 826 imagine you had 827 828 data Data (a :: k) (b :: k) (c :: k) 829 830 Then you'd want to derived instance to be: 831 832 instance C (Data (a :: *)) 833 834 Not: 835 836 instance C (Data (a :: k)) 837 8382. We naïvely come up with instance constraints using the following criteria: 839 840 (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind 841 variables), then generate a Functor n constraint, and if k1/k2 are kind 842 variables, then substitute k1/k2 with * elsewhere in the types. We must 843 consider the case where they are kind variables because you might have a 844 scenario like this: 845 846 newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2) 847 = Compose (f (g a b)) 848 849 Which would have a derived Bifunctor instance of: 850 851 instance (Functor f, Bifunctor g) => Bifunctor (Compose f g) where ... 852 (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are 853 * or kind variables), then generate a Bifunctor n constraint and perform 854 kind substitution as in the other case. 855-} 856 857{- 858Note [Matching functions with GADT type variables] 859~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 860 861When deriving Bifoldable, there is a tricky corner case to consider: 862 863 data Both a b where 864 BothCon :: x -> x -> Both x x 865 866Which fold functions should be applied to which arguments of BothCon? We have a 867choice, since both the function of type (a -> m) and of type (b -> m) can be 868applied to either argument. In such a scenario, the second fold function takes 869precedence over the first fold function, so the derived Bifoldable instance would be: 870 871 instance Bifoldable Both where 872 bifoldMap _ g (BothCon x1 x2) = g x1 <> g x2 873 874This is not an arbitrary choice, as this definition ensures that 875bifoldMap id = Foldable.foldMap for a derived Bifoldable instance for Both. 876-} 877 878------------------------------------------------------------------------------- 879-- Error messages 880------------------------------------------------------------------------------- 881 882-- | Either the given data type doesn't have enough type variables, or one of 883-- the type variables to be eta-reduced cannot realize kind *. 884derivingKindError :: BiClass -> Name -> Q a 885derivingKindError biClass tyConName = fail 886 . showString "Cannot derive well-kinded instance of form ‘" 887 . showString className 888 . showChar ' ' 889 . showParen True 890 ( showString (nameBase tyConName) 891 . showString " ..." 892 ) 893 . showString "‘\n\tClass " 894 . showString className 895 . showString " expects an argument of kind * -> * -> *" 896 $ "" 897 where 898 className :: String 899 className = nameBase $ biClassName biClass 900 901-- | One of the last two type variables appeard in a contravariant position 902-- when deriving Bifoldable or Bitraversable. 903contravarianceError :: Name -> Q a 904contravarianceError conName = fail 905 . showString "Constructor ‘" 906 . showString (nameBase conName) 907 . showString "‘ must not use the last type variable(s) in a function argument" 908 $ "" 909 910-- | A constructor has a function argument in a derived Bifoldable or Bitraversable 911-- instance. 912noFunctionsError :: Name -> Q a 913noFunctionsError conName = fail 914 . showString "Constructor ‘" 915 . showString (nameBase conName) 916 . showString "‘ must not contain function types" 917 $ "" 918 919-- | The data type has a DatatypeContext which mentions one of the eta-reduced 920-- type variables. 921datatypeContextError :: Name -> Type -> Q a 922datatypeContextError dataName instanceType = fail 923 . showString "Can't make a derived instance of ‘" 924 . showString (pprint instanceType) 925 . showString "‘:\n\tData type ‘" 926 . showString (nameBase dataName) 927 . showString "‘ must not have a class context involving the last type argument(s)" 928 $ "" 929 930-- | The data type has an existential constraint which mentions one of the 931-- eta-reduced type variables. 932existentialContextError :: Name -> Q a 933existentialContextError conName = fail 934 . showString "Constructor ‘" 935 . showString (nameBase conName) 936 . showString "‘ must be truly polymorphic in the last argument(s) of the data type" 937 $ "" 938 939-- | The data type mentions one of the n eta-reduced type variables in a place other 940-- than the last nth positions of a data type in a constructor's field. 941outOfPlaceTyVarError :: Name -> Q a 942outOfPlaceTyVarError conName = fail 943 . showString "Constructor ‘" 944 . showString (nameBase conName) 945 . showString "‘ must only use its last two type variable(s) within" 946 . showString " the last two argument(s) of a data type" 947 $ "" 948 949-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce 950-- function for the criteria it would have to meet). 951etaReductionError :: Type -> Q a 952etaReductionError instanceType = fail $ 953 "Cannot eta-reduce to an instance of form \n\tinstance (...) => " 954 ++ pprint instanceType 955 956------------------------------------------------------------------------------- 957-- Class-specific constants 958------------------------------------------------------------------------------- 959 960-- | A representation of which class is being derived. 961data BiClass = Bifunctor | Bifoldable | Bitraversable 962 963-- | A representation of which function is being generated. 964data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse 965 deriving Eq 966 967biFunConstName :: BiFun -> Name 968biFunConstName Bimap = bimapConstValName 969biFunConstName Bifoldr = bifoldrConstValName 970biFunConstName BifoldMap = bifoldMapConstValName 971biFunConstName Bitraverse = bitraverseConstValName 972 973biClassName :: BiClass -> Name 974biClassName Bifunctor = bifunctorTypeName 975biClassName Bifoldable = bifoldableTypeName 976biClassName Bitraversable = bitraversableTypeName 977 978biFunName :: BiFun -> Name 979biFunName Bimap = bimapValName 980biFunName Bifoldr = bifoldrValName 981biFunName BifoldMap = bifoldMapValName 982biFunName Bitraverse = bitraverseValName 983 984biClassToFuns :: BiClass -> [BiFun] 985biClassToFuns Bifunctor = [Bimap] 986biClassToFuns Bifoldable = [Bifoldr, BifoldMap] 987biClassToFuns Bitraversable = [Bitraverse] 988 989biFunToClass :: BiFun -> BiClass 990biFunToClass Bimap = Bifunctor 991biFunToClass Bifoldr = Bifoldable 992biFunToClass BifoldMap = Bifoldable 993biFunToClass Bitraverse = Bitraversable 994 995biClassConstraint :: BiClass -> Int -> Maybe Name 996biClassConstraint Bifunctor 1 = Just functorTypeName 997biClassConstraint Bifoldable 1 = Just foldableTypeName 998biClassConstraint Bitraversable 1 = Just traversableTypeName 999biClassConstraint biClass 2 = Just $ biClassName biClass 1000biClassConstraint _ _ = Nothing 1001 1002fmapArity :: Int -> Name 1003fmapArity 1 = fmapValName 1004fmapArity 2 = bimapValName 1005fmapArity n = arityErr n 1006 1007foldrArity :: Int -> Name 1008foldrArity 1 = foldrValName 1009foldrArity 2 = bifoldrValName 1010foldrArity n = arityErr n 1011 1012foldMapArity :: Int -> Name 1013foldMapArity 1 = foldMapValName 1014foldMapArity 2 = bifoldMapValName 1015foldMapArity n = arityErr n 1016 1017traverseArity :: Int -> Name 1018traverseArity 1 = traverseValName 1019traverseArity 2 = bitraverseValName 1020traverseArity n = arityErr n 1021 1022arityErr :: Int -> a 1023arityErr n = error $ "Unsupported arity: " ++ show n 1024 1025allowExQuant :: BiClass -> Bool 1026allowExQuant Bifoldable = True 1027allowExQuant _ = False 1028 1029biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp 1030biFunEmptyCase biFun z value = 1031 biFunTrivial emptyCase 1032 (varE pureValName `appE` emptyCase) 1033 biFun z 1034 where 1035 emptyCase :: Q Exp 1036 emptyCase = caseE (varE value) [] 1037 1038biFunNoCons :: BiFun -> Name -> Name -> Q Exp 1039biFunNoCons biFun z value = 1040 biFunTrivial seqAndError 1041 (varE pureValName `appE` seqAndError) 1042 biFun z 1043 where 1044 seqAndError :: Q Exp 1045 seqAndError = appE (varE seqValName) (varE value) `appE` 1046 appE (varE errorValName) 1047 (stringE $ "Void " ++ nameBase (biFunName biFun)) 1048 1049biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp 1050biFunTrivial bimapE bitraverseE biFun z = go biFun 1051 where 1052 go :: BiFun -> Q Exp 1053 go Bimap = bimapE 1054 go Bifoldr = varE z 1055 go BifoldMap = varE memptyValName 1056 go Bitraverse = bitraverseE 1057 1058{- 1059Note [ft_triv for Bifoldable and Bitraversable] 1060~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1061When deriving Bifoldable and Bitraversable, we filter out any subexpressions whose 1062type does not mention one of the last two type parameters. From this, you might 1063think that we don't need to implement ft_triv for bifoldr, bifoldMap, or 1064bitraverse at all, but in fact we do need to. Imagine the following data type: 1065 1066 data T a b = MkT a (T Int b) 1067 1068In a derived Bifoldable T instance, you would generate the following bifoldMap 1069definition: 1070 1071 bifoldMap f g (MkT a1 a2) = f a1 <> bifoldMap (\_ -> mempty) g arg2 1072 1073You need to fill in bi_triv (\_ -> mempty) as the first argument to the recursive 1074call to bifoldMap, since that is how the algorithm handles polymorphic recursion. 1075-} 1076 1077------------------------------------------------------------------------------- 1078-- Generic traversal for functor-like deriving 1079------------------------------------------------------------------------------- 1080 1081-- Much of the code below is cargo-culted from the TcGenFunctor module in GHC. 1082 1083data FFoldType a -- Describes how to fold over a Type in a functor like way 1084 = FT { ft_triv :: a 1085 -- ^ Does not contain variables 1086 , ft_var :: Name -> a 1087 -- ^ A bare variable 1088 , ft_co_var :: Name -> a 1089 -- ^ A bare variable, contravariantly 1090 , ft_fun :: a -> a -> a 1091 -- ^ Function type 1092 , ft_tup :: TupleSort -> [a] -> a 1093 -- ^ Tuple type. The [a] is the result of folding over the 1094 -- arguments of the tuple. 1095 , ft_ty_app :: [(Type, a)] -> a 1096 -- ^ Type app, variables only in last argument. The [(Type, a)] 1097 -- represents the last argument types. That is, they form the 1098 -- argument parts of @fun_ty arg_ty_1 ... arg_ty_n@. 1099 , ft_bad_app :: a 1100 -- ^ Type app, variable other than in last arguments 1101 , ft_forall :: [TyVarBndrSpec] -> a -> a 1102 -- ^ Forall type 1103 } 1104 1105-- Note that in GHC, this function is pure. It must be monadic here since we: 1106-- 1107-- (1) Expand type synonyms 1108-- (2) Detect type family applications 1109-- 1110-- Which require reification in Template Haskell, but are pure in Core. 1111functorLikeTraverse :: forall a. 1112 TyVarMap -- ^ Variables to look for 1113 -> FFoldType a -- ^ How to fold 1114 -> Type -- ^ Type to process 1115 -> Q a 1116functorLikeTraverse tvMap (FT { ft_triv = caseTrivial, ft_var = caseVar 1117 , ft_co_var = caseCoVar, ft_fun = caseFun 1118 , ft_tup = caseTuple, ft_ty_app = caseTyApp 1119 , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) 1120 ty 1121 = do ty' <- resolveTypeSynonyms ty 1122 (res, _) <- go False ty' 1123 return res 1124 where 1125 go :: Bool -- Covariant or contravariant context 1126 -> Type 1127 -> Q (a, Bool) -- (result of type a, does type contain var) 1128 go co t@AppT{} 1129 | (ArrowT, [funArg, funRes]) <- unapplyTy t 1130 = do (funArgR, funArgC) <- go (not co) funArg 1131 (funResR, funResC) <- go co funRes 1132 if funArgC || funResC 1133 then return (caseFun funArgR funResR, True) 1134 else trivial 1135 go co t@AppT{} = do 1136 let (f, args) = unapplyTy t 1137 (_, fc) <- go co f 1138 (xrs, xcs) <- fmap unzip $ mapM (go co) args 1139 let numLastArgs, numFirstArgs :: Int 1140 numLastArgs = min 2 $ length args 1141 numFirstArgs = length args - numLastArgs 1142 1143 tuple :: TupleSort -> Q (a, Bool) 1144 tuple tupSort = return (caseTuple tupSort xrs, True) 1145 1146 wrongArg :: Q (a, Bool) 1147 wrongArg = return (caseWrongArg, True) 1148 1149 case () of 1150 _ | not (or xcs) 1151 -> trivial -- Variable does not occur 1152 -- At this point we know that xrs, xcs is not empty, 1153 -- and at least one xr is True 1154 | TupleT len <- f 1155 -> tuple $ Boxed len 1156#if MIN_VERSION_template_haskell(2,6,0) 1157 | UnboxedTupleT len <- f 1158 -> tuple $ Unboxed len 1159#endif 1160 | fc || or (take numFirstArgs xcs) 1161 -> wrongArg -- T (..var..) ty_1 ... ty_n 1162 | otherwise -- T (..no var..) ty_1 ... ty_n 1163 -> do itf <- isInTypeFamilyApp tyVarNames f args 1164 if itf -- We can't decompose type families, so 1165 -- error if we encounter one here. 1166 then wrongArg 1167 else return ( caseTyApp $ drop numFirstArgs $ zip args xrs 1168 , True ) 1169 go co (SigT t k) = do 1170 (_, kc) <- go_kind co k 1171 if kc 1172 then return (caseWrongArg, True) 1173 else go co t 1174 go co (VarT v) 1175 | Map.member v tvMap 1176 = return (if co then caseCoVar v else caseVar v, True) 1177 | otherwise 1178 = trivial 1179 go co (ForallT tvbs _ t) = do 1180 (tr, tc) <- go co t 1181 let tvbNames = map tvName tvbs 1182 if not tc || any (`elem` tvbNames) tyVarNames 1183 then trivial 1184 else return (caseForAll tvbs tr, True) 1185 go _ _ = trivial 1186 1187 go_kind :: Bool 1188 -> Kind 1189 -> Q (a, Bool) 1190#if MIN_VERSION_template_haskell(2,9,0) 1191 go_kind = go 1192#else 1193 go_kind _ _ = trivial 1194#endif 1195 1196 trivial :: Q (a, Bool) 1197 trivial = return (caseTrivial, False) 1198 1199 tyVarNames :: [Name] 1200 tyVarNames = Map.keys tvMap 1201 1202-- Fold over the arguments of a data constructor in a Functor-like way. 1203foldDataConArgs :: forall a. TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a] 1204foldDataConArgs tvMap ft con = do 1205 fieldTys <- mapM resolveTypeSynonyms $ constructorFields con 1206 mapM foldArg fieldTys 1207 where 1208 foldArg :: Type -> Q a 1209 foldArg = functorLikeTraverse tvMap ft 1210 1211-- Make a 'LamE' using a fresh variable. 1212mkSimpleLam :: (Exp -> Q Exp) -> Q Exp 1213mkSimpleLam lam = do 1214 -- Use an underscore in front of the variable name, as it's possible for 1215 -- certain Bifoldable instances to generate code like this (see #89): 1216 -- 1217 -- @ 1218 -- bifoldMap (\\_n -> mempty) ... 1219 -- @ 1220 -- 1221 -- Without the underscore, that code would trigger -Wunused-matches warnings. 1222 n <- newName "_n" 1223 body <- lam (VarE n) 1224 return $ LamE [VarP n] body 1225 1226-- Make a 'LamE' using two fresh variables. 1227mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp 1228mkSimpleLam2 lam = do 1229 -- Use an underscore in front of the variable name, as it's possible for 1230 -- certain Bifoldable instances to generate code like this (see #89): 1231 -- 1232 -- @ 1233 -- bifoldr (\\_n1 n2 -> n2) ... 1234 -- @ 1235 -- 1236 -- Without the underscore, that code would trigger -Wunused-matches warnings. 1237 n1 <- newName "_n1" 1238 n2 <- newName "n2" 1239 body <- lam (VarE n1) (VarE n2) 1240 return $ LamE [VarP n1, VarP n2] body 1241 1242-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" 1243-- 1244-- @mkSimpleConMatch fold conName insides@ produces a match clause in 1245-- which the LHS pattern-matches on @extraPats@, followed by a match on the 1246-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over 1247-- @conName@ and its arguments, applying an expression (from @insides@) to each 1248-- of the respective arguments of @conName@. 1249mkSimpleConMatch :: (Name -> [a] -> Q Exp) 1250 -> Name 1251 -> [Exp -> a] 1252 -> Q Match 1253mkSimpleConMatch fold conName insides = do 1254 varsNeeded <- newNameList "_arg" $ length insides 1255 let pat = conPCompat conName (map VarP varsNeeded) 1256 rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded) 1257 return $ Match pat (NormalB rhs) [] 1258 1259-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" 1260-- 1261-- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to 1262-- 'mkSimpleConMatch', with two key differences: 1263-- 1264-- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it 1265-- filters out the expressions corresponding to arguments whose types do not 1266-- mention the last type variable in a derived 'Foldable' or 'Traversable' 1267-- instance (i.e., those elements of @insides@ containing @False@). 1268-- 1269-- 2. @fold@ takes an expression as its first argument instead of a 1270-- constructor name. This is because it uses a specialized 1271-- constructor function expression that only takes as many parameters as 1272-- there are argument types that mention the last type variable. 1273mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp) 1274 -> Name 1275 -> [(Bool, Exp)] 1276 -> Q Match 1277mkSimpleConMatch2 fold conName insides = do 1278 varsNeeded <- newNameList "_arg" lengthInsides 1279 let pat = conPCompat conName (map VarP varsNeeded) 1280 -- Make sure to zip BEFORE invoking catMaybes. We want the variable 1281 -- indicies in each expression to match up with the argument indices 1282 -- in conExpr (defined below). 1283 exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v) 1284 else Nothing) 1285 insides varsNeeded 1286 -- An element of argTysTyVarInfo is True if the constructor argument 1287 -- with the same index has a type which mentions the last type 1288 -- variable. 1289 argTysTyVarInfo = map (\(m, _) -> m) insides 1290 (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded 1291 1292 conExpQ 1293 | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar) 1294 | otherwise = do 1295 bs <- newNameList "b" lengthInsides 1296 let bs' = filterByList argTysTyVarInfo bs 1297 vars = filterByLists argTysTyVarInfo 1298 (map varE bs) (map varE varsNeeded) 1299 lamE (map varP bs') (appsE (conE conName:vars)) 1300 1301 conExp <- conExpQ 1302 rhs <- fold conExp exps 1303 return $ Match pat (NormalB rhs) [] 1304 where 1305 lengthInsides = length insides 1306 1307-- Indicates whether a tuple is boxed or unboxed, as well as its number of 1308-- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #) 1309-- corresponds to @Unboxed 3@. 1310data TupleSort 1311 = Boxed Int 1312#if MIN_VERSION_template_haskell(2,6,0) 1313 | Unboxed Int 1314#endif 1315 1316-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" 1317mkSimpleTupleCase :: (Name -> [a] -> Q Match) 1318 -> TupleSort -> [a] -> Exp -> Q Exp 1319mkSimpleTupleCase matchForCon tupSort insides x = do 1320 let tupDataName = case tupSort of 1321 Boxed len -> tupleDataName len 1322#if MIN_VERSION_template_haskell(2,6,0) 1323 Unboxed len -> unboxedTupleDataName len 1324#endif 1325 m <- matchForCon tupDataName insides 1326 return $ CaseE x [m] 1327 1328-- Adapt to the type of ConP changing in template-haskell-2.18.0.0. 1329conPCompat :: Name -> [Pat] -> Pat 1330conPCompat n pats = ConP n 1331#if MIN_VERSION_template_haskell(2,18,0) 1332 [] 1333#endif 1334 pats 1335