1{-# LANGUAGE CPP #-} 2 3#if __GLASGOW_HASKELL__ >= 704 4{-# LANGUAGE Unsafe #-} 5#endif 6 7{-| 8Module: Data.Bifunctor.TH.Internal 9Copyright: (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott 10License: BSD-style (see the file LICENSE) 11Maintainer: Edward Kmett 12Portability: Template Haskell 13 14Template Haskell-related utilities. 15-} 16module Data.Bifunctor.TH.Internal where 17 18import Data.Foldable (foldr') 19import qualified Data.List as List 20import qualified Data.Map as Map (singleton) 21import Data.Map (Map) 22import Data.Maybe (fromMaybe, mapMaybe) 23import qualified Data.Set as Set 24import Data.Set (Set) 25 26import Language.Haskell.TH.Datatype 27import Language.Haskell.TH.Lib 28import Language.Haskell.TH.Syntax 29 30-- Ensure, beyond a shadow of a doubt, that the instances are in-scope 31import Data.Bifunctor () 32import Data.Bifoldable () 33import Data.Bitraversable () 34 35#ifndef CURRENT_PACKAGE_KEY 36import Data.Version (showVersion) 37import Paths_bifunctors (version) 38#endif 39 40------------------------------------------------------------------------------- 41-- Expanding type synonyms 42------------------------------------------------------------------------------- 43 44applySubstitutionKind :: Map Name Kind -> Type -> Type 45#if MIN_VERSION_template_haskell(2,8,0) 46applySubstitutionKind = applySubstitution 47#else 48applySubstitutionKind _ t = t 49#endif 50 51substNameWithKind :: Name -> Kind -> Type -> Type 52substNameWithKind n k = applySubstitutionKind (Map.singleton n k) 53 54substNamesWithKindStar :: [Name] -> Type -> Type 55substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns 56 57------------------------------------------------------------------------------- 58-- Type-specialized const functions 59------------------------------------------------------------------------------- 60 61bimapConst :: p b d -> (a -> b) -> (c -> d) -> p a c -> p b d 62bimapConst = const . const . const 63{-# INLINE bimapConst #-} 64 65bifoldrConst :: c -> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c 66bifoldrConst = const . const . const . const 67{-# INLINE bifoldrConst #-} 68 69bifoldMapConst :: m -> (a -> m) -> (b -> m) -> p a b -> m 70bifoldMapConst = const . const . const 71{-# INLINE bifoldMapConst #-} 72 73bitraverseConst :: f (t c d) -> (a -> f c) -> (b -> f d) -> t a b -> f (t c d) 74bitraverseConst = const . const . const 75{-# INLINE bitraverseConst #-} 76 77------------------------------------------------------------------------------- 78-- StarKindStatus 79------------------------------------------------------------------------------- 80 81-- | Whether a type is not of kind *, is of kind *, or is a kind variable. 82data StarKindStatus = NotKindStar 83 | KindStar 84 | IsKindVar Name 85 deriving Eq 86 87-- | Does a Type have kind * or k (for some kind variable k)? 88canRealizeKindStar :: Type -> StarKindStatus 89canRealizeKindStar t 90 | hasKindStar t = KindStar 91 | otherwise = case t of 92#if MIN_VERSION_template_haskell(2,8,0) 93 SigT _ (VarT k) -> IsKindVar k 94#endif 95 _ -> NotKindStar 96 97-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. 98-- Otherwise, returns 'Nothing'. 99starKindStatusToName :: StarKindStatus -> Maybe Name 100starKindStatusToName (IsKindVar n) = Just n 101starKindStatusToName _ = Nothing 102 103-- | Concat together all of the StarKindStatuses that are IsKindVar and extract 104-- the kind variables' Names out. 105catKindVarNames :: [StarKindStatus] -> [Name] 106catKindVarNames = mapMaybe starKindStatusToName 107 108------------------------------------------------------------------------------- 109-- Assorted utilities 110------------------------------------------------------------------------------- 111 112-- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) 113 114-- | 'filterByList' takes a list of Bools and a list of some elements and 115-- filters out these elements for which the corresponding value in the list of 116-- Bools is False. This function does not check whether the lists have equal 117-- length. 118filterByList :: [Bool] -> [a] -> [a] 119filterByList (True:bs) (x:xs) = x : filterByList bs xs 120filterByList (False:bs) (_:xs) = filterByList bs xs 121filterByList _ _ = [] 122 123-- | 'filterByLists' takes a list of Bools and two lists as input, and 124-- outputs a new list consisting of elements from the last two input lists. For 125-- each Bool in the list, if it is 'True', then it takes an element from the 126-- former list. If it is 'False', it takes an element from the latter list. 127-- The elements taken correspond to the index of the Bool in its list. 128-- For example: 129-- 130-- @ 131-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" 132-- @ 133-- 134-- This function does not check whether the lists have equal length. 135filterByLists :: [Bool] -> [a] -> [a] -> [a] 136filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys 137filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys 138filterByLists _ _ _ = [] 139 140-- | 'partitionByList' takes a list of Bools and a list of some elements and 141-- partitions the list according to the list of Bools. Elements corresponding 142-- to 'True' go to the left; elements corresponding to 'False' go to the right. 143-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ 144-- This function does not check whether the lists have equal 145-- length. 146partitionByList :: [Bool] -> [a] -> ([a], [a]) 147partitionByList = go [] [] 148 where 149 go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs 150 go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs 151 go trues falses _ _ = (reverse trues, reverse falses) 152 153-- | Returns True if a Type has kind *. 154hasKindStar :: Type -> Bool 155hasKindStar VarT{} = True 156#if MIN_VERSION_template_haskell(2,8,0) 157hasKindStar (SigT _ StarT) = True 158#else 159hasKindStar (SigT _ StarK) = True 160#endif 161hasKindStar _ = False 162 163-- Returns True is a kind is equal to *, or if it is a kind variable. 164isStarOrVar :: Kind -> Bool 165#if MIN_VERSION_template_haskell(2,8,0) 166isStarOrVar StarT = True 167isStarOrVar VarT{} = True 168#else 169isStarOrVar StarK = True 170#endif 171isStarOrVar _ = False 172 173-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form 174-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or 175-- kind variables. 176hasKindVarChain :: Int -> Type -> Maybe [Name] 177hasKindVarChain kindArrows t = 178 let uk = uncurryKind (tyKind t) 179 in if (length uk - 1 == kindArrows) && all isStarOrVar uk 180 then Just (freeVariables uk) 181 else Nothing 182 183-- | If a Type is a SigT, returns its kind signature. Otherwise, return *. 184tyKind :: Type -> Kind 185tyKind (SigT _ k) = k 186tyKind _ = starK 187 188-- | A mapping of type variable Names to their map function Names. For example, in a 189-- Bifunctor declaration, a TyVarMap might look like (a ~> f, b ~> g), where 190-- a and b are the last two type variables of the datatype, and f and g are the two 191-- functions which map their respective type variables. 192type TyVarMap = Map Name Name 193 194thd3 :: (a, b, c) -> c 195thd3 (_, _, c) = c 196 197unsnoc :: [a] -> Maybe ([a], a) 198unsnoc [] = Nothing 199unsnoc (x:xs) = case unsnoc xs of 200 Nothing -> Just ([], x) 201 Just (a,b) -> Just (x:a, b) 202 203-- | Generate a list of fresh names with a common prefix, and numbered suffixes. 204newNameList :: String -> Int -> Q [Name] 205newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] 206 207-- | Applies a typeclass constraint to a type. 208applyClass :: Name -> Name -> Pred 209#if MIN_VERSION_template_haskell(2,10,0) 210applyClass con t = AppT (ConT con) (VarT t) 211#else 212applyClass con t = ClassP con [VarT t] 213#endif 214 215-- | Checks to see if the last types in a data family instance can be safely eta- 216-- reduced (i.e., dropped), given the other types. This checks for three conditions: 217-- 218-- (1) All of the dropped types are type variables 219-- (2) All of the dropped types are distinct 220-- (3) None of the remaining types mention any of the dropped types 221canEtaReduce :: [Type] -> [Type] -> Bool 222canEtaReduce remaining dropped = 223 all isTyVar dropped 224 && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type 225 -- didn't have an Ord instance until template-haskell-2.10.0.0 226 && not (any (`mentionsName` droppedNames) remaining) 227 where 228 droppedNames :: [Name] 229 droppedNames = map varTToName dropped 230 231-- | Extract Just the Name from a type variable. If the argument Type is not a 232-- type variable, return Nothing. 233varTToName_maybe :: Type -> Maybe Name 234varTToName_maybe (VarT n) = Just n 235varTToName_maybe (SigT t _) = varTToName_maybe t 236varTToName_maybe _ = Nothing 237 238-- | Extract the Name from a type variable. If the argument Type is not a 239-- type variable, throw an error. 240varTToName :: Type -> Name 241varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe 242 243-- | Peel off a kind signature from a Type (if it has one). 244unSigT :: Type -> Type 245unSigT (SigT t _) = t 246unSigT t = t 247 248-- | Is the given type a variable? 249isTyVar :: Type -> Bool 250isTyVar (VarT _) = True 251isTyVar (SigT t _) = isTyVar t 252isTyVar _ = False 253 254-- | Detect if a Name in a list of provided Names occurs as an argument to some 255-- type family. This makes an effort to exclude /oversaturated/ arguments to 256-- type families. For instance, if one declared the following type family: 257-- 258-- @ 259-- type family F a :: Type -> Type 260-- @ 261-- 262-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, 263-- but not @b@. 264isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool 265isInTypeFamilyApp names tyFun tyArgs = 266 case tyFun of 267 ConT tcName -> go tcName 268 _ -> return False 269 where 270 go :: Name -> Q Bool 271 go tcName = do 272 info <- reify tcName 273 case info of 274#if MIN_VERSION_template_haskell(2,11,0) 275 FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ 276 -> withinFirstArgs bndrs 277#elif MIN_VERSION_template_haskell(2,7,0) 278 FamilyI (FamilyD TypeFam _ bndrs _) _ 279 -> withinFirstArgs bndrs 280#else 281 TyConI (FamilyD TypeFam _ bndrs _) 282 -> withinFirstArgs bndrs 283#endif 284 285#if MIN_VERSION_template_haskell(2,11,0) 286 FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ 287 -> withinFirstArgs bndrs 288#elif MIN_VERSION_template_haskell(2,9,0) 289 FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ 290 -> withinFirstArgs bndrs 291#endif 292 293 _ -> return False 294 where 295 withinFirstArgs :: [a] -> Q Bool 296 withinFirstArgs bndrs = 297 let firstArgs = take (length bndrs) tyArgs 298 argFVs = freeVariables firstArgs 299 in return $ any (`elem` argFVs) names 300 301-- | Are all of the items in a list (which have an ordering) distinct? 302-- 303-- This uses Set (as opposed to nub) for better asymptotic time complexity. 304allDistinct :: Ord a => [a] -> Bool 305allDistinct = allDistinct' Set.empty 306 where 307 allDistinct' :: Ord a => Set a -> [a] -> Bool 308 allDistinct' uniqs (x:xs) 309 | x `Set.member` uniqs = False 310 | otherwise = allDistinct' (Set.insert x uniqs) xs 311 allDistinct' _ _ = True 312 313-- | Does the given type mention any of the Names in the list? 314mentionsName :: Type -> [Name] -> Bool 315mentionsName = go 316 where 317 go :: Type -> [Name] -> Bool 318 go (AppT t1 t2) names = go t1 names || go t2 names 319 go (SigT t _k) names = go t names 320#if MIN_VERSION_template_haskell(2,8,0) 321 || go _k names 322#endif 323 go (VarT n) names = n `elem` names 324 go _ _ = False 325 326-- | Does an instance predicate mention any of the Names in the list? 327predMentionsName :: Pred -> [Name] -> Bool 328#if MIN_VERSION_template_haskell(2,10,0) 329predMentionsName = mentionsName 330#else 331predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys 332predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names 333#endif 334 335-- | Construct a type via curried application. 336applyTy :: Type -> [Type] -> Type 337applyTy = List.foldl' AppT 338 339-- | Fully applies a type constructor to its type variables. 340applyTyCon :: Name -> [Type] -> Type 341applyTyCon = applyTy . ConT 342 343-- | Split an applied type into its individual components. For example, this: 344-- 345-- @ 346-- Either Int Char 347-- @ 348-- 349-- would split to this: 350-- 351-- @ 352-- [Either, Int, Char] 353-- @ 354unapplyTy :: Type -> (Type, [Type]) 355unapplyTy ty = go ty ty [] 356 where 357 go :: Type -> Type -> [Type] -> (Type, [Type]) 358 go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) 359 go origTy (SigT ty' _) args = go origTy ty' args 360#if MIN_VERSION_template_haskell(2,11,0) 361 go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args 362 go origTy (ParensT ty') args = go origTy ty' args 363#endif 364 go origTy _ args = (origTy, args) 365 366-- | Split a type signature by the arrows on its spine. For example, this: 367-- 368-- @ 369-- forall a b. (a ~ b) => (a -> b) -> Char -> () 370-- @ 371-- 372-- would split to this: 373-- 374-- @ 375-- (a ~ b, [a -> b, Char, ()]) 376-- @ 377uncurryTy :: Type -> (Cxt, [Type]) 378uncurryTy (AppT (AppT ArrowT t1) t2) = 379 let (ctxt, tys) = uncurryTy t2 380 in (ctxt, t1:tys) 381uncurryTy (SigT t _) = uncurryTy t 382uncurryTy (ForallT _ ctxt t) = 383 let (ctxt', tys) = uncurryTy t 384 in (ctxt ++ ctxt', tys) 385uncurryTy t = ([], [t]) 386 387-- | Like uncurryType, except on a kind level. 388uncurryKind :: Kind -> [Kind] 389#if MIN_VERSION_template_haskell(2,8,0) 390uncurryKind = snd . uncurryTy 391#else 392uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 393uncurryKind k = [k] 394#endif 395 396------------------------------------------------------------------------------- 397-- Manually quoted names 398------------------------------------------------------------------------------- 399 400-- By manually generating these names we avoid needing to use the 401-- TemplateHaskell language extension when compiling the bifunctors library. 402-- This allows the library to be used in stage1 cross-compilers. 403 404bifunctorsPackageKey :: String 405#ifdef CURRENT_PACKAGE_KEY 406bifunctorsPackageKey = CURRENT_PACKAGE_KEY 407#else 408bifunctorsPackageKey = "bifunctors-" ++ showVersion version 409#endif 410 411mkBifunctorsName_tc :: String -> String -> Name 412mkBifunctorsName_tc = mkNameG_tc bifunctorsPackageKey 413 414mkBifunctorsName_v :: String -> String -> Name 415mkBifunctorsName_v = mkNameG_v bifunctorsPackageKey 416 417bimapConstValName :: Name 418bimapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bimapConst" 419 420bifoldrConstValName :: Name 421bifoldrConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldrConst" 422 423bifoldMapConstValName :: Name 424bifoldMapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst" 425 426coerceValName :: Name 427coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" 428 429bitraverseConstValName :: Name 430bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst" 431 432wrapMonadDataName :: Name 433wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad" 434 435functorTypeName :: Name 436functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" 437 438foldableTypeName :: Name 439foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" 440 441traversableTypeName :: Name 442traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable" 443 444composeValName :: Name 445composeValName = mkNameG_v "base" "GHC.Base" "." 446 447idValName :: Name 448idValName = mkNameG_v "base" "GHC.Base" "id" 449 450errorValName :: Name 451errorValName = mkNameG_v "base" "GHC.Err" "error" 452 453flipValName :: Name 454flipValName = mkNameG_v "base" "GHC.Base" "flip" 455 456fmapValName :: Name 457fmapValName = mkNameG_v "base" "GHC.Base" "fmap" 458 459foldrValName :: Name 460foldrValName = mkNameG_v "base" "Data.Foldable" "foldr" 461 462foldMapValName :: Name 463foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" 464 465seqValName :: Name 466seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" 467 468traverseValName :: Name 469traverseValName = mkNameG_v "base" "Data.Traversable" "traverse" 470 471unwrapMonadValName :: Name 472unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad" 473 474#if MIN_VERSION_base(4,8,0) 475bifunctorTypeName :: Name 476bifunctorTypeName = mkNameG_tc "base" "Data.Bifunctor" "Bifunctor" 477 478bimapValName :: Name 479bimapValName = mkNameG_v "base" "Data.Bifunctor" "bimap" 480 481pureValName :: Name 482pureValName = mkNameG_v "base" "GHC.Base" "pure" 483 484apValName :: Name 485apValName = mkNameG_v "base" "GHC.Base" "<*>" 486 487liftA2ValName :: Name 488liftA2ValName = mkNameG_v "base" "GHC.Base" "liftA2" 489 490mappendValName :: Name 491mappendValName = mkNameG_v "base" "GHC.Base" "mappend" 492 493memptyValName :: Name 494memptyValName = mkNameG_v "base" "GHC.Base" "mempty" 495#else 496bifunctorTypeName :: Name 497bifunctorTypeName = mkBifunctorsName_tc "Data.Bifunctor" "Bifunctor" 498 499bimapValName :: Name 500bimapValName = mkBifunctorsName_v "Data.Bifunctor" "bimap" 501 502pureValName :: Name 503pureValName = mkNameG_v "base" "Control.Applicative" "pure" 504 505apValName :: Name 506apValName = mkNameG_v "base" "Control.Applicative" "<*>" 507 508liftA2ValName :: Name 509liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2" 510 511mappendValName :: Name 512mappendValName = mkNameG_v "base" "Data.Monoid" "mappend" 513 514memptyValName :: Name 515memptyValName = mkNameG_v "base" "Data.Monoid" "mempty" 516#endif 517 518#if MIN_VERSION_base(4,10,0) 519bifoldableTypeName :: Name 520bifoldableTypeName = mkNameG_tc "base" "Data.Bifoldable" "Bifoldable" 521 522bitraversableTypeName :: Name 523bitraversableTypeName = mkNameG_tc "base" "Data.Bitraversable" "Bitraversable" 524 525bifoldrValName :: Name 526bifoldrValName = mkNameG_v "base" "Data.Bifoldable" "bifoldr" 527 528bifoldMapValName :: Name 529bifoldMapValName = mkNameG_v "base" "Data.Bifoldable" "bifoldMap" 530 531bitraverseValName :: Name 532bitraverseValName = mkNameG_v "base" "Data.Bitraversable" "bitraverse" 533#else 534bifoldableTypeName :: Name 535bifoldableTypeName = mkBifunctorsName_tc "Data.Bifoldable" "Bifoldable" 536 537bitraversableTypeName :: Name 538bitraversableTypeName = mkBifunctorsName_tc "Data.Bitraversable" "Bitraversable" 539 540bifoldrValName :: Name 541bifoldrValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldr" 542 543bifoldMapValName :: Name 544bifoldMapValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldMap" 545 546bitraverseValName :: Name 547bitraverseValName = mkBifunctorsName_v "Data.Bitraversable" "bitraverse" 548#endif 549 550#if MIN_VERSION_base(4,11,0) 551appEndoValName :: Name 552appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo" 553 554dualDataName :: Name 555dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual" 556 557endoDataName :: Name 558endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo" 559 560getDualValName :: Name 561getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual" 562#else 563appEndoValName :: Name 564appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" 565 566dualDataName :: Name 567dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" 568 569endoDataName :: Name 570endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" 571 572getDualValName :: Name 573getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" 574#endif 575