bifunctors 5.4.2 → 5.5

raw patch · 6 files changed

+331/−484 lines, 6 filesdep +th-abstractionPVP ok

version bump matches the API change (PVP)

Dependencies added: th-abstraction

API changes (from Hackage documentation)

Files

• .travis.yml +3/−3
• CHANGELOG.markdown +16/−0
• bifunctors.cabal +3/−2
• src/Data/Bifunctor/TH.hs +270/−363
• src/Data/Bifunctor/TH/Internal.hs +18/−116
• tests/BifunctorSpec.hs +21/−0

@@ -34,9 +34,9 @@     - env: CABALVER=1.24 GHCVER=8.0.2       compiler: ": #GHC 8.0.2"       addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}}-    - env: CABALVER=2.0 GHCVER=8.2.1-      compiler: ": #GHC 8.2.1"-      addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}}+    - env: CABALVER=2.0 GHCVER=8.2.2+      compiler: ": #GHC 8.2.2"+      addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}     - env: CABALVER=head GHCVER=head       compiler: ": #GHC head"       addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}}

@@ -1,3 +1,19 @@+5.5 [2017.12.07]+---+* `Data.Bifunctor.TH` now derives `bimap`/`bitraverse`+  implementations for empty data types that are strict in the argument.+* `Data.Bifunctor.TH` no longer derives `bifoldr`/`bifoldMap` implementations+  that error on empty data types. Instead, they simply return the folded state+  (for `bifoldr`) or `mempty` (for `bifoldMap`).+* When using `Data.Bifunctor.TH` to derive `Bifunctor` or `Bitraversable`+  instances for data types where the last two type variables are at phantom+  roles, generated `bimap`/`bitraverse` implementations now use `coerce` for+  efficiency.+* Add `Options` to `Data.Bifunctor.TH`, along with variants of existing+  functions that take `Options` as an argument. For now, the only configurable+  option is whether derived instances for empty data types should use the+  `EmptyCase` extension (this is disabled by default).+ 5.4.2 ----- * Make `deriveBitraversable` use `liftA2` in derived implementations of `bitraverse` when possible, now that `liftA2` is a class method of `Applicative` (as of GHC 8.2)

@@ -1,6 +1,6 @@ name:          bifunctors category:      Data, Functors-version:       5.4.2+version:       5.5 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -13,7 +13,7 @@ synopsis:      Bifunctors description:   Bifunctors build-type:    Simple-tested-with:   GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2+tested-with:   GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2 extra-source-files: .travis.yml CHANGELOG.markdown README.markdown  source-repository head@@ -44,6 +44,7 @@     comonad             >= 4     && < 6,     containers          >= 0.1   && < 0.6,     template-haskell    >= 2.4   && < 2.13,+    th-abstraction      >= 0.2.2 && < 0.3,     transformers        >= 0.2   && < 0.6,     transformers-compat >= 0.5   && < 0.6 

@@ -31,32 +31,45 @@     -- $make     -- * 'Bifunctor'     deriveBifunctor+  , deriveBifunctorOptions   , makeBimap+  , makeBimapOptions     -- * 'Bifoldable'   , deriveBifoldable+  , deriveBifoldableOptions   , makeBifold+  , makeBifoldOptions   , makeBifoldMap+  , makeBifoldMapOptions   , makeBifoldr+  , makeBifoldrOptions   , makeBifoldl+  , makeBifoldlOptions     -- * 'Bitraversable'   , deriveBitraversable+  , deriveBitraversableOptions   , makeBitraverse+  , makeBitraverseOptions   , makeBisequenceA+  , makeBisequenceAOptions   , makeBimapM+  , makeBimapMOptions   , makeBisequence+  , makeBisequenceOptions+    -- * 'Options'+  , Options(..)+  , defaultOptions   ) where  import           Control.Monad (guard, unless, when, zipWithM)  import           Data.Bifunctor.TH.Internal import           Data.Either (rights)-#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))-import           Data.Foldable (foldr')-#endif import           Data.List import qualified Data.Map as Map (fromList, keys, lookup, size) import           Data.Maybe +import           Language.Haskell.TH.Datatype import           Language.Haskell.TH.Lib import           Language.Haskell.TH.Ppr import           Language.Haskell.TH.Syntax@@ -65,6 +78,22 @@ -- User-facing API ------------------------------------------------------------------------------- +-- | Options that further configure how the functions in "Data.Bifunctor.TH"+-- should behave.+newtype Options = Options+  { emptyCaseBehavior :: Bool+    -- ^ If 'True', derived instances for empty data types (i.e., ones with+    --   no data constructors) will use the @EmptyCase@ language extension.+    --   If 'False', derived instances will simply use 'seq' instead.+    --   (This has no effect on GHCs before 7.8, since @EmptyCase@ is only+    --   available in 7.8 or later.)+  } deriving (Eq, Ord, Read, Show)++-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to+-- prevent users from having to enable that extension at use sites.)+defaultOptions :: Options+defaultOptions = Options { emptyCaseBehavior = False }+ {- $derive  'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically@@ -166,40 +195,68 @@ -- | Generates a 'Bifunctor' instance declaration for the given data type or data -- family instance. deriveBifunctor :: Name -> Q [Dec]-deriveBifunctor = deriveBiClass Bifunctor+deriveBifunctor = deriveBifunctorOptions defaultOptions +-- | Like 'deriveBifunctor', but takes an 'Options' argument.+deriveBifunctorOptions :: Options -> Name -> Q [Dec]+deriveBifunctorOptions = deriveBiClass Bifunctor+ -- | Generates a lambda expression which behaves like 'bimap' (without requiring a -- 'Bifunctor' instance). makeBimap :: Name -> Q Exp-makeBimap = makeBiFun Bimap+makeBimap = makeBimapOptions defaultOptions +-- | Like 'makeBimap', but takes an 'Options' argument.+makeBimapOptions :: Options -> Name -> Q Exp+makeBimapOptions = makeBiFun Bimap+ -- | Generates a 'Bifoldable' instance declaration for the given data type or data -- family instance. deriveBifoldable :: Name -> Q [Dec]-deriveBifoldable = deriveBiClass Bifoldable+deriveBifoldable = deriveBifoldableOptions defaultOptions --- | Generates a lambda expression which behaves like 'bifold' (without requiring a+-- | Like 'deriveBifoldable', but takes an 'Options' argument.+deriveBifoldableOptions :: Options -> Name -> Q [Dec]+deriveBifoldableOptions = deriveBiClass Bifoldable++--- | Generates a lambda expression which behaves like 'bifold' (without requiring a -- 'Bifoldable' instance). makeBifold :: Name -> Q Exp-makeBifold name = appsE [ makeBifoldMap name-                        , varE idValName-                        , varE idValName-                        ]+makeBifold = makeBifoldOptions defaultOptions --- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring a--- 'Bifoldable' instance).+-- | Like 'makeBifold', but takes an 'Options' argument.+makeBifoldOptions :: Options -> Name -> Q Exp+makeBifoldOptions opts name = appsE [ makeBifoldMapOptions opts name+                                    , varE idValName+                                    , varE idValName+                                    ]++-- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring+-- a 'Bifoldable' instance). makeBifoldMap :: Name -> Q Exp-makeBifoldMap = makeBiFun BifoldMap+makeBifoldMap = makeBifoldMapOptions defaultOptions +-- | Like 'makeBifoldMap', but takes an 'Options' argument.+makeBifoldMapOptions :: Options -> Name -> Q Exp+makeBifoldMapOptions = makeBiFun BifoldMap+ -- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a -- 'Bifoldable' instance). makeBifoldr :: Name -> Q Exp-makeBifoldr = makeBiFun Bifoldr+makeBifoldr = makeBifoldrOptions defaultOptions +-- | Like 'makeBifoldr', but takes an 'Options' argument.+makeBifoldrOptions :: Options -> Name -> Q Exp+makeBifoldrOptions = makeBiFun Bifoldr+ -- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a -- 'Bifoldable' instance). makeBifoldl :: Name -> Q Exp-makeBifoldl name = do+makeBifoldl = makeBifoldlOptions defaultOptions++-- | Like 'makeBifoldl', but takes an 'Options' argument.+makeBifoldlOptions :: Options -> Name -> Q Exp+makeBifoldlOptions opts name = do   f <- newName "f"   g <- newName "g"   z <- newName "z"@@ -207,7 +264,10 @@   lamE [varP f, varP g, varP z, varP t] $     appsE [ varE appEndoValName           , appsE [ varE getDualValName-                  , appsE [ makeBifoldMap name, foldFun f, foldFun g, varE t]+                  , appsE [ makeBifoldMapOptions opts name+                          , foldFun f+                          , foldFun g+                          , varE t]                   ]           , varE z           ]@@ -223,112 +283,195 @@ -- | Generates a 'Bitraversable' instance declaration for the given data type or data -- family instance. deriveBitraversable :: Name -> Q [Dec]-deriveBitraversable = deriveBiClass Bitraversable+deriveBitraversable = deriveBitraversableOptions defaultOptions --- | Generates a lambda expression which behaves like 'bitraverse' (without requiring a--- 'Bitraversable' instance).+-- | Like 'deriveBitraversable', but takes an 'Options' argument.+deriveBitraversableOptions :: Options -> Name -> Q [Dec]+deriveBitraversableOptions = deriveBiClass Bitraversable++-- | Generates a lambda expression which behaves like 'bitraverse' (without+-- requiring a 'Bitraversable' instance). makeBitraverse :: Name -> Q Exp-makeBitraverse = makeBiFun Bitraverse+makeBitraverse = makeBitraverseOptions defaultOptions --- | Generates a lambda expression which behaves like 'bisequenceA' (without requiring a--- 'Bitraversable' instance).+-- | Like 'makeBitraverse', but takes an 'Options' argument.+makeBitraverseOptions :: Options -> Name -> Q Exp+makeBitraverseOptions = makeBiFun Bitraverse++-- | Generates a lambda expression which behaves like 'bisequenceA' (without+-- requiring a 'Bitraversable' instance). makeBisequenceA :: Name -> Q Exp-makeBisequenceA name = appsE [ makeBitraverse name-                             , varE idValName-                             , varE idValName-                             ]+makeBisequenceA = makeBisequenceAOptions defaultOptions --- | Generates a lambda expression which behaves like 'bimapM' (without requiring a--- 'Bitraversable' instance).+-- | Like 'makeBitraverseA', but takes an 'Options' argument.+makeBisequenceAOptions :: Options -> Name -> Q Exp+makeBisequenceAOptions opts name = appsE [ makeBitraverseOptions opts name+                                         , varE idValName+                                         , varE idValName+                                         ]++-- | Generates a lambda expression which behaves like 'bimapM' (without+-- requiring a 'Bitraversable' instance). makeBimapM :: Name -> Q Exp-makeBimapM name = do+makeBimapM = makeBimapMOptions defaultOptions++-- | Like 'makeBimapM', but takes an 'Options' argument.+makeBimapMOptions :: Options -> Name -> Q Exp+makeBimapMOptions opts name = do   f <- newName "f"   g <- newName "g"   lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $-                          appsE [makeBitraverse name, wrapMonadExp f, wrapMonadExp g]+                          appsE [ makeBitraverseOptions opts name+                                , wrapMonadExp f+                                , wrapMonadExp g+                                ]   where     wrapMonadExp :: Name -> Q Exp     wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) --- | Generates a lambda expression which behaves like 'bisequence' (without requiring a--- 'Bitraversable' instance).+-- | Generates a lambda expression which behaves like 'bisequence' (without+-- requiring a 'Bitraversable' instance). makeBisequence :: Name -> Q Exp-makeBisequence name = appsE [ makeBimapM name-                            , varE idValName-                            , varE idValName-                            ]+makeBisequence = makeBisequenceOptions defaultOptions +-- | Like 'makeBisequence', but takes an 'Options' argument.+makeBisequenceOptions :: Options -> Name -> Q Exp+makeBisequenceOptions opts name = appsE [ makeBimapMOptions opts name+                                        , varE idValName+                                        , varE idValName+                                        ]+ ------------------------------------------------------------------------------- -- Code generation -------------------------------------------------------------------------------  -- | Derive a class instance declaration (depending on the BiClass argument's value).-deriveBiClass :: BiClass -> Name -> Q [Dec]-deriveBiClass biClass name = withType name fromCons where-  fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]-  fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do-    (instanceCxt, instanceType)-        <- buildTypeInstance biClass name' ctxt tvbs mbTys-    instanceD (return instanceCxt)-              (return instanceType)-              (biFunDecs biClass cons)+deriveBiClass :: BiClass -> Options -> Name -> Q [Dec]+deriveBiClass biClass opts name = do+  info <- reifyDatatype name+  case info of+    DatatypeInfo { datatypeContext = ctxt+                 , datatypeName    = parentName+                 , datatypeVars    = vars+                 , datatypeVariant = variant+                 , datatypeCons    = cons+                 } -> do+      (instanceCxt, instanceType)+          <- buildTypeInstance biClass parentName ctxt vars variant+      (:[]) `fmap` instanceD (return instanceCxt)+                             (return instanceType)+                             (biFunDecs biClass opts parentName vars cons)  -- | Generates a declaration defining the primary function(s) corresponding to a -- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and -- bitraverse for Bitraversable). -- -- For why both bifoldr and bifoldMap are derived for Bifoldable, see Trac #7436.-biFunDecs :: BiClass -> [Con] -> [Q Dec]-biFunDecs biClass cons = map makeFunD $ biClassToFuns biClass where-  makeFunD :: BiFun -> Q Dec-  makeFunD biFun =-    funD (biFunName biFun)-         [ clause []-                  (normalB $ makeBiFunForCons biFun cons)-                  []-         ]+biFunDecs :: BiClass -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]+biFunDecs biClass opts parentName vars cons =+  map makeFunD $ biClassToFuns biClass+  where+    makeFunD :: BiFun -> Q Dec+    makeFunD biFun =+      funD (biFunName biFun)+           [ clause []+                    (normalB $ makeBiFunForCons biFun opts parentName vars cons)+                    []+           ]  -- | Generates a lambda expression which behaves like the BiFun argument.-makeBiFun :: BiFun -> Name -> Q Exp-makeBiFun biFun name = withType name fromCons where-  fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp-  fromCons name' ctxt tvbs cons mbTys =-    -- We force buildTypeInstance here since it performs some checks for whether-    -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc.-    -- implemented for it, and produces errors if it can't.-    buildTypeInstance (biFunToClass biFun) name' ctxt tvbs mbTys-      `seq` makeBiFunForCons biFun cons+makeBiFun :: BiFun -> Options -> Name -> Q Exp+makeBiFun biFun opts name = do+  info <- reifyDatatype name+  case info of+    DatatypeInfo { datatypeContext = ctxt+                 , datatypeName    = parentName+                 , datatypeVars    = vars+                 , datatypeVariant = variant+                 , datatypeCons    = cons+                 } ->+      -- We force buildTypeInstance here since it performs some checks for whether+      -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc.+      -- implemented for it, and produces errors if it can't.+      buildTypeInstance (biFunToClass biFun) parentName ctxt vars variant+        >> makeBiFunForCons biFun opts parentName vars cons  -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type.-makeBiFunForCons :: BiFun -> [Con] -> Q Exp-makeBiFunForCons biFun cons = do+makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp+makeBiFunForCons biFun opts _parentName vars cons = do   argNames <- mapM newName $ catMaybes [ Just "f"                                        , Just "g"                                        , guard (biFun == Bifoldr) >> Just "z"                                        , Just "value"                                        ]   let ([map1, map2], others) = splitAt 2 argNames-      z     = head others -- If we're deriving bifoldr, this will be well defined-                          -- and useful. Otherwise, it'll be ignored.-      value = last others+      z          = head others -- If we're deriving bifoldr, this will be well defined+                               -- and useful. Otherwise, it'll be ignored.+      value      = last others+      lastTyVars = map varTToName $ drop (length vars - 2) vars+      tvMap      = Map.fromList $ zip lastTyVars [map1, map2]   lamE (map varP argNames)       . appsE       $ [ varE $ biFunConstName biFun-        , if null cons-             then appE (varE errorValName)-                       (stringE $ "Void " ++ nameBase (biFunName biFun))-             else caseE (varE value)-                        (map (makeBiFunForCon biFun z map1 map2) cons)+        , makeFun z value tvMap         ] ++ map varE argNames+  where+    makeFun :: Name -> Name -> TyVarMap -> Q Exp+    makeFun z value tvMap = do+#if MIN_VERSION_template_haskell(2,9,0)+      roles <- reifyRoles _parentName+#endif+      case () of+        _ +#if MIN_VERSION_template_haskell(2,9,0)+          | Just (rs, PhantomR) <- unsnoc roles+          , Just (_,  PhantomR) <- unsnoc rs+         -> biFunPhantom z value+#endif++          | null cons && emptyCaseBehavior opts && ghc7'8OrLater+         -> biFunEmptyCase biFun z value++          | null cons+         -> biFunNoCons biFun z value++          | otherwise+         -> caseE (varE value)+                  (map (makeBiFunForCon biFun z tvMap) cons)++    ghc7'8OrLater :: Bool+#if __GLASGOW_HASKELL__ >= 708+    ghc7'8OrLater = True+#else+    ghc7'8OrLater = False+#endif++#if MIN_VERSION_template_haskell(2,9,0)+    biFunPhantom :: Name -> Name -> Q Exp+    biFunPhantom z value =+        biFunTrivial coerce+                     (varE pureValName `appE` coerce)+                     biFun z+      where+        coerce :: Q Exp+        coerce = varE coerceValName `appE` varE value+#endif+ -- | Generates a lambda expression for a single constructor.-makeBiFunForCon :: BiFun -> Name -> Name -> Name -> Con -> Q Match-makeBiFunForCon biFun z map1 map2 con = do-  let conName = constructorName con-  (ts, tvMap) <- reifyConTys biFun conName map1 map2-  argNames    <- newNameList "_arg" $ length ts-  makeBiFunForArgs biFun z tvMap conName ts argNames+makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match+makeBiFunForCon biFun z tvMap+  (ConstructorInfo { constructorName    = conName+                   , constructorContext = ctxt+                   , constructorFields  = ts }) = do+    ts'      <- mapM resolveTypeSynonyms ts+    argNames <- newNameList "_arg" $ length ts'+    if (any (`predMentionsName` Map.keys tvMap) ctxt+          || Map.size tvMap < 2)+          && not (allowExQuant (biFunToClass biFun))+       then existentialContextError conName+       else makeBiFunForArgs biFun z tvMap conName ts' argNames  -- | Generates a lambda expression for a single constructor's arguments. makeBiFunForArgs :: BiFun@@ -455,196 +598,27 @@ -- Template Haskell reifying and AST manipulation ------------------------------------------------------------------------------- --- | Boilerplate for top level splices.------ The given Name must meet one of two criteria:------ 1. It must be the name of a type constructor of a plain data type or newtype.--- 2. It must be the name of a data family instance or newtype instance constructor.------ Any other value will result in an exception.-withType :: Name-         -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)-         -> Q a-withType name f = do-  info <- reify name-  case info of-    TyConI dec ->-      case dec of-        DataD ctxt _ tvbs-#if MIN_VERSION_template_haskell(2,11,0)-              _-#endif-              cons _ -> f name ctxt tvbs cons Nothing-        NewtypeD ctxt _ tvbs-#if MIN_VERSION_template_haskell(2,11,0)-                 _-#endif-                 con _ -> f name ctxt tvbs [con] Nothing-        _ -> error $ ns ++ "Unsupported type: " ++ show dec-#if MIN_VERSION_template_haskell(2,7,0)-# if MIN_VERSION_template_haskell(2,11,0)-    DataConI _ _ parentName   -> do-# else-    DataConI _ _ parentName _ -> do-# endif-      parentInfo <- reify parentName-      case parentInfo of-# if MIN_VERSION_template_haskell(2,11,0)-        FamilyI (DataFamilyD _ tvbs _) decs ->-# else-        FamilyI (FamilyD DataFam _ tvbs _) decs ->-# endif-          let instDec = flip find decs $ \dec -> case dec of-                DataInstD _ _ _-# if MIN_VERSION_template_haskell(2,11,0)-                          _-# endif-                          cons _ -> any ((name ==) . constructorName) cons-                NewtypeInstD _ _ _-# if MIN_VERSION_template_haskell(2,11,0)-                             _-# endif-                             con _ -> name == constructorName con-                _ -> error $ ns ++ "Must be a data or newtype instance."-           in case instDec of-                Just (DataInstD ctxt _ instTys-# if MIN_VERSION_template_haskell(2,11,0)-                                _-# endif-                                cons _)-                  -> f parentName ctxt tvbs cons $ Just instTys-                Just (NewtypeInstD ctxt _ instTys-# if MIN_VERSION_template_haskell(2,11,0)-                                   _-# endif-                                   con _)-                  -> f parentName ctxt tvbs [con] $ Just instTys-                _ -> error $ ns ++-                  "Could not find data or newtype instance constructor."-        _ -> error $ ns ++ "Data constructor " ++ show name ++-          " is not from a data family instance constructor."-# if MIN_VERSION_template_haskell(2,11,0)-    FamilyI DataFamilyD{} _ ->-# else-    FamilyI (FamilyD DataFam _ _ _) _ ->-# endif-      error $ ns ++-        "Cannot use a data family name. Use a data family instance constructor instead."-    _ -> error $ ns ++ "The name must be of a plain data type constructor, "-                    ++ "or a data family instance constructor."-#else-    DataConI{} -> dataConIError-    _          -> error $ ns ++ "The name must be of a plain type constructor."-#endif-  where-    ns :: String-    ns = "Data.Bifunctor.TH.withType: "---- | Deduces the instance context and head for an instance.+-- For the given Types, generate an instance context and head. Coming up with+-- the instance type isn't as simple as dropping the last types, as you need to+-- be wary of kinds being instantiated with *.+-- See Note [Type inference in derived instances] buildTypeInstance :: BiClass                   -- ^ Bifunctor, Bifoldable, or Bitraversable                   -> Name                   -- ^ The type constructor or data family name                   -> Cxt                   -- ^ The datatype context-                  -> [TyVarBndr]-                  -- ^ The type variables from the data type/data family declaration-                  -> Maybe [Type]-                  -- ^ 'Just' the types used to instantiate a data family instance,-                  -- or 'Nothing' if it's a plain data type+                  -> [Type]+                  -- ^ The types to instantiate the instance with+                  -> DatatypeVariant+                  -- ^ Are we dealing with a data family instance or not                   -> Q (Cxt, Type)--- Plain data type/newtype case-buildTypeInstance biClass tyConName dataCxt tvbs Nothing =-    let varTys :: [Type]-        varTys = map tvbToType tvbs-    in buildTypeInstanceFromTys biClass tyConName dataCxt varTys False--- Data family instance case------ The CPP is present to work around a couple of annoying old GHC bugs.--- See Note [Polykinded data families in Template Haskell]-buildTypeInstance biClass parentName dataCxt tvbs (Just instTysAndKinds) = do-#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)-    let instTys :: [Type]-        instTys = zipWith stealKindForType tvbs instTysAndKinds-#else-    let kindVarNames :: [Name]-        kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs--        numKindVars :: Int-        numKindVars = length kindVarNames--        givenKinds, givenKinds' :: [Kind]-        givenTys                :: [Type]-        (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds-        givenKinds' = map sanitizeStars givenKinds--        -- A GHC 7.6-specific bug requires us to replace all occurrences of-        -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.-        -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.-        sanitizeStars :: Kind -> Kind-        sanitizeStars = go-          where-            go :: Kind -> Kind-            go (AppT t1 t2)                 = AppT (go t1) (go t2)-            go (SigT t k)                   = SigT (go t) (go k)-            go (ConT n) | n == starKindName = StarT-            go t                            = t--    -- If we run this code with GHC 7.8, we might have to generate extra type-    -- variables to compensate for any type variables that Template Haskell-    -- eta-reduced away.-    -- See Note [Polykinded data families in Template Haskell]-    xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)--    let xTys   :: [Type]-        xTys = map VarT xTypeNames-        -- ^ Because these type variables were eta-reduced away, we can only-        --   determine their kind by using stealKindForType. Therefore, we mark-        --   them as VarT to ensure they will be given an explicit kind annotation-        --   (and so the kind inference machinery has the right information).--        substNamesWithKinds :: [(Name, Kind)] -> Type -> Type-        substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks--        -- The types from the data family instance might not have explicit kind-        -- annotations, which the kind machinery needs to work correctly. To-        -- compensate, we use stealKindForType to explicitly annotate any-        -- types without kind annotations.-        instTys :: [Type]-        instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))-                  -- Note that due to a GHC 7.8-specific bug-                  -- (see Note [Polykinded data families in Template Haskell]),-                  -- there may be more kind variable names than there are kinds-                  -- to substitute. But this is OK! If a kind is eta-reduced, it-                  -- means that is was not instantiated to something more specific,-                  --   so we need not substitute it. Using stealKindForType will-                  --   grab the correct kind.-                $ zipWith stealKindForType tvbs (givenTys ++ xTys)-#endif-    buildTypeInstanceFromTys biClass parentName dataCxt instTys True---- For the given Types, generate an instance context and head. Coming up with--- the instance type isn't as simple as dropping the last types, as you need to--- be wary of kinds being instantiated with *.--- See Note [Type inference in derived instances]-buildTypeInstanceFromTys :: BiClass-                         -- ^ Bifunctor, Bifoldable, or Bitraversable-                         -> Name-                         -- ^ The type constructor or data family name-                         -> Cxt-                         -- ^ The datatype context-                         -> [Type]-                         -- ^ The types to instantiate the instance with-                         -> Bool-                         -- ^ True if it's a data family, False otherwise-                         -> Q (Cxt, Type)-buildTypeInstanceFromTys biClass tyConName dataCxt varTysOrig isDataFamily = do+buildTypeInstance biClass tyConName dataCxt varTysOrig variant = do     -- Make sure to expand through type/kind synonyms! Otherwise, the     -- eta-reduction check might get tripped up over type variables in a     -- synonym that are actually dropped.     -- (See GHC Trac #11416 for a scenario where this actually happened.)-    varTysExp <- mapM expandSyn varTysOrig+    varTysExp <- mapM resolveTypeSynonyms varTysOrig      let remainingLength :: Int         remainingLength = length varTysOrig - 2@@ -674,7 +648,7 @@         -- All of the type variables mentioned in the dropped types         -- (post-synonym expansion)         droppedTyVarNames :: [Name]-        droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst+        droppedTyVarNames = freeVariables droppedTysExpSubst      -- If any of the dropped types were polykinded, ensure that they are of kind *     -- after substituting * for the dropped kind variables. If not, throw an error.@@ -715,6 +689,13 @@           map (substNamesWithKindStar (union droppedKindVarNames kvNames'))             $ take remainingLength varTysOrig +        isDataFamily :: Bool+        isDataFamily = case variant of+                         Datatype        -> False+                         Newtype         -> False+                         DataInstance    -> True+                         NewtypeInstance -> True+         remainingTysOrigSubst' :: [Type]         -- See Note [Kind signatures in derived instances] for an explanation         -- of the isDataFamily check.@@ -759,55 +740,6 @@     tName = varTToName t  {--Note [Polykinded data families in Template Haskell]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In order to come up with the correct instance context and head for an instance, e.g.,--  instance C a => C (Data a) where ...--We need to know the exact types and kinds used to instantiate the instance. For-plain old datatypes, this is simple: every type must be a type variable, and-Template Haskell reliably tells us the type variables and their kinds.--Doing the same for data families proves to be much harder for three reasons:--1. On any version of Template Haskell, it may not tell you what an instantiated-   type's kind is. For instance, in the following data family instance:--     data family Fam (f :: * -> *) (a :: *)-     data instance Fam f a--   Then if we use TH's reify function, it would tell us the TyVarBndrs of the-   data family declaration are:--     [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]--   and the instantiated types of the data family instance are:--     [VarT f1,VarT a1]--   We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we-   have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the-   kind is in case an instantiated type isn't a SigT, so we use the stealKindForType-   function to ensure all of the instantiated types are SigTs before passing them-   to buildTypeInstanceFromTys.-2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of-   the specified kinds of a data family instance efore any of the instantiated-   types. Fortunately, this is easy to deal with: you simply count the number of-   distinct kind variables in the data family declaration, take that many elements-   from the front of the  Types list of the data family instance, substitute the-   kind variables with their respective instantiated kinds (which you took earlier),-   and proceed as normal.-3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template-   Haskell might not even list all of the Types of a data family instance, since-   they are eta-reduced away! And yes, kinds can be eta-reduced too.--   The simplest workaround is to count how many instantiated types are missing from-   the list and generate extra type variables to use in their place. Luckily, we-   needn't worry much if its kind was eta-reduced away, since using stealKindForType-   will get it back.- Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -883,49 +815,6 @@         kind substitution as in the other case. -} --- Determines the types of a constructor's arguments as well as the last type--- parameters (along with their map functions), expanding through any type synonyms.--- The type parameters are determined on a constructor-by-constructor basis since--- they may be refined to be particular types in a GADT.-reifyConTys :: BiFun-            -> Name-            -> Name-            -> Name-            -> Q ([Type], TyVarMap)-reifyConTys biFun conName map1 map2 = do-    info          <- reify conName-    (ctxt, uncTy) <- case info of-        DataConI _ ty _-#if !(MIN_VERSION_template_haskell(2,11,0))-                 _-#endif-                 -> fmap uncurryTy (expandSyn ty)-        _ -> error "Must be a data constructor"-    let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy-        unapResTy = unapplyTy resTy-        -- If one of the last type variables is refined to a particular type-        -- (i.e., not truly polymorphic), we mark it with Nothing and filter-        -- it out later, since we only apply map functions to arguments of-        -- a type that it (1) one of the last type variables, and (2)-        -- of a truly polymorphic type.-        mbTvNames = map varTToName_maybe $-                        drop (length unapResTy - 2) unapResTy-        -- We use Map.fromList to ensure that if there are any duplicate type-        -- variables (as can happen in a GADT), the rightmost type variable gets-        -- associated with the map function.-        ---        -- See Note [Matching functions with GADT type variables]-        tvMap = Map.fromList-                    . catMaybes -- Drop refined types-                    $ zipWith (\mbTvName sp ->-                                  fmap (\tvName -> (tvName, sp)) mbTvName)-                              mbTvNames [map1, map2]-    if (any (`predMentionsName` Map.keys tvMap) ctxt-         || Map.size tvMap < 2)-         && not (allowExQuant (biFunToClass biFun))-       then existentialContextError conName-       else return (argTys, tvMap)- {- Note [Matching functions with GADT type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1025,17 +914,6 @@   "Cannot eta-reduce to an instance of form \n\tinstance (...) => "   ++ pprint instanceType -#if !(MIN_VERSION_template_haskell(2,7,0))--- | Template Haskell didn't list all of a data family's instances upon reification--- until template-haskell-2.7.0.0, which is necessary for a derived instance to work.-dataConIError :: a-dataConIError = error-  . showString "Cannot use a data constructor."-  . showString "\n\t(Note: if you are trying to derive for a data family instance,"-  . showString "\n\tuse GHC >= 7.4 instead.)"-  $ ""-#endif- ------------------------------------------------------------------------------- -- Class-specific constants -------------------------------------------------------------------------------@@ -1195,6 +1073,35 @@           (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es      return . go . rights $ ess++biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp+biFunEmptyCase biFun z value =+    biFunTrivial emptyCase+                 (varE pureValName `appE` emptyCase)+                 biFun z+  where+    emptyCase :: Q Exp+    emptyCase = caseE (varE value) []++biFunNoCons :: BiFun -> Name -> Name -> Q Exp+biFunNoCons biFun z value =+    biFunTrivial seqAndError+                 (varE pureValName `appE` seqAndError)+                 biFun z+  where+    seqAndError :: Q Exp+    seqAndError = appE (varE seqValName) (varE value) `appE`+                  appE (varE errorValName)+                        (stringE $ "Void " ++ nameBase (biFunName biFun))++biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp+biFunTrivial bimapE bitraverseE biFun z = go biFun+  where+    go :: BiFun -> Q Exp+    go Bimap      = bimapE+    go Bifoldr    = varE z+    go BifoldMap  = varE memptyValName+    go Bitraverse = bitraverseE  {- Note [biFunTriv for Bifoldable and Bitraversable]

@@ -15,17 +15,16 @@ -} module Data.Bifunctor.TH.Internal where -import           Control.Monad (liftM)- import           Data.Bifunctor (bimap) import           Data.Foldable (foldr') import           Data.List-import qualified Data.Map as Map (fromList, findWithDefault, singleton)+import qualified Data.Map as Map (singleton) import           Data.Map (Map) import           Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import           Data.Set (Set) +import           Language.Haskell.TH.Datatype import           Language.Haskell.TH.Lib import           Language.Haskell.TH.Syntax @@ -43,73 +42,15 @@ -- Expanding type synonyms ------------------------------------------------------------------------------- --- | Expands all type synonyms in a type. Written by Dan Rosén in the--- @genifunctors@ package (licensed under BSD3).-expandSyn :: Type -> Q Type-expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t-expandSyn t@AppT{}            = expandSynApp t []-expandSyn t@ConT{}            = expandSynApp t []-expandSyn (SigT t k)          = do t' <- expandSyn t-                                   k' <- expandSynKind k-                                   return (SigT t' k')-expandSyn t                   = return t--expandSynKind :: Kind -> Q Kind-#if MIN_VERSION_template_haskell(2,8,0)-expandSynKind = expandSyn-#else-expandSynKind = return -- There are no kind synonyms to deal with-#endif--expandSynApp :: Type -> [Type] -> Q Type-expandSynApp (AppT t1 t2) ts = do-    t2' <- expandSyn t2-    expandSynApp t1 (t2':ts)-expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts-expandSynApp t@(ConT n) ts = do-    info <- reify n-    case info of-        TyConI (TySynD _ tvs rhs) ->-            let (ts', ts'') = splitAt (length tvs) ts-                subs = mkSubst tvs ts'-                rhs' = substType subs rhs-             in expandSynApp rhs' ts''-        _ -> return $ foldl' AppT t ts-expandSynApp t ts = do-    t' <- expandSyn t-    return $ foldl' AppT t' ts--type TypeSubst = Map Name Type-type KindSubst = Map Name Kind--mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst-mkSubst vs ts =-   let vs' = map un vs-       un (PlainTV v)    = v-       un (KindedTV v _) = v-   in Map.fromList $ zip vs' ts--substType :: TypeSubst -> Type -> Type-substType subs (ForallT v c t) = ForallT v c $ substType subs t-substType subs t@(VarT n)      = Map.findWithDefault t n subs-substType subs (AppT t1 t2)    = AppT (substType subs t1) (substType subs t2)-substType subs (SigT t k)      = SigT (substType subs t)-#if MIN_VERSION_template_haskell(2,8,0)-                                      (substType subs k)-#else-                                      k-#endif-substType _ t                  = t--substKind :: KindSubst -> Type -> Type+applySubstitutionKind :: Map Name Kind -> Type -> Type #if MIN_VERSION_template_haskell(2,8,0)-substKind = substType+applySubstitutionKind = applySubstitution #else-substKind _ = id -- There are no kind variables!+applySubstitutionKind _ t = t #endif  substNameWithKind :: Name -> Kind -> Type -> Type-substNameWithKind n k = substKind (Map.singleton n k)+substNameWithKind n k = applySubstitutionKind (Map.singleton n k)  substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns@@ -254,27 +195,6 @@ #endif isStarOrVar _      = False --- | Gets all of the type/kind variable names mentioned somewhere in a Type.-tyVarNamesOfType :: Type -> [Name]-tyVarNamesOfType = go-  where-    go :: Type -> [Name]-    go (AppT t1 t2) = go t1 ++ go t2-    go (SigT t _k)  = go t-#if MIN_VERSION_template_haskell(2,8,0)-                           ++ go _k-#endif-    go (VarT n)     = [n]-    go _            = []---- | Gets all of the type/kind variable names mentioned somewhere in a Kind.-tyVarNamesOfKind :: Kind -> [Name]-#if MIN_VERSION_template_haskell(2,8,0)-tyVarNamesOfKind = tyVarNamesOfType-#else-tyVarNamesOfKind _ = [] -- There are no kind variables-#endif- -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or -- kind variables.@@ -282,7 +202,7 @@ hasKindVarChain kindArrows t =   let uk = uncurryKind (tyKind t)   in if (length uk - 1 == kindArrows) && all isStarOrVar uk-        then Just (concatMap tyVarNamesOfKind uk)+        then Just (freeVariables uk)         else Nothing  -- | If a Type is a SigT, returns its kind signature. Otherwise, return *.@@ -290,15 +210,6 @@ tyKind (SigT _ k) = k tyKind _          = starK --- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.-stealKindForType :: TyVarBndr -> Type -> Type-stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)-stealKindForType _   t        = t---- | Monadic version of concatMap-concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-concatMapM f xs = liftM concat (mapM f xs)- -- | A mapping of type variable Names to their map function Names. For example, in a -- Bifunctor declaration, a TyVarMap might look like (a ~> f, b ~> g), where -- a and b are the last two type variables of the datatype, and f and g are the two@@ -308,31 +219,16 @@ thd3 :: (a, b, c) -> c thd3 (_, _, c) = c --- | Extracts the name of a constructor.-constructorName :: Con -> Name-constructorName (NormalC name      _  ) = name-constructorName (RecC    name      _  ) = name-constructorName (InfixC  _    name _  ) = name-constructorName (ForallC _    _    con) = constructorName con-#if MIN_VERSION_template_haskell(2,11,0)-constructorName (GadtC    names _ _)    = head names-constructorName (RecGadtC names _ _)    = head names-#endif+unsnoc :: [a] -> Maybe ([a], a)+unsnoc []     = Nothing+unsnoc (x:xs) = case unsnoc xs of+                  Nothing    -> Just ([], x)+                  Just (a,b) -> Just (x:a, b)  -- | Generate a list of fresh names with a common prefix, and numbered suffixes. newNameList :: String -> Int -> Q [Name] newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] --- | Extracts the kind from a TyVarBndr.-tvbKind :: TyVarBndr -> Kind-tvbKind (PlainTV  _)   = starK-tvbKind (KindedTV _ k) = k---- | Convert a TyVarBndr to a Type.-tvbToType :: TyVarBndr -> Type-tvbToType (PlainTV n)    = VarT n-tvbToType (KindedTV n k) = SigT (VarT n) k- -- | Applies a typeclass constraint to a type. applyClass :: Name -> Name -> Pred #if MIN_VERSION_template_haskell(2,10,0)@@ -520,6 +416,9 @@ bifoldMapConstValName :: Name bifoldMapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst" +coerceValName :: Name+coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce"+ bitraverseConstValName :: Name bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst" @@ -567,6 +466,9 @@  getDualValName :: Name getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"++seqValName :: Name+seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq"  traverseValName :: Name traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}@@ -8,6 +9,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE RoleAnnotations #-}+#endif+ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} #if __GLASGOW_HASKELL__ >= 800@@ -105,6 +111,12 @@ data IntHashFun a b     = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) +data Empty1 a b+data Empty2 a b+#if __GLASGOW_HASKELL__ >= 708+type role Empty2 nominal nominal+#endif+ -- Data families  data family   StrangeFam x  y z@@ -207,6 +219,15 @@ $(deriveBitraversable ''IntHash)  $(deriveBifunctor     ''IntHashFun)++$(deriveBifunctor     ''Empty1)+$(deriveBifoldable    ''Empty1)+$(deriveBitraversable ''Empty1)++-- Use EmptyCase here+$(deriveBifunctorOptions     defaultOptions{emptyCaseBehavior = True} ''Empty2)+$(deriveBifoldableOptions    defaultOptions{emptyCaseBehavior = True} ''Empty2)+$(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2)  #if MIN_VERSION_template_haskell(2,7,0) -- Data families