1{-# LANGUAGE CPP #-} 2 3{-| 4Module: Data.Functor.Invariant.TH.Internal 5Copyright: (C) 2012-2017 Nicolas Frisby, (C) 2015-2017 Ryan Scott 6License: BSD-style (see the file LICENSE) 7Maintainer: Ryan Scott 8Portability: Template Haskell 9 10Template Haskell-related utilities. 11-} 12module Data.Functor.Invariant.TH.Internal where 13 14import Data.Foldable (foldr') 15import Data.Functor.Invariant () -- To import the instances 16import Data.List 17import qualified Data.Map as Map (singleton) 18import Data.Map (Map) 19import Data.Maybe (fromMaybe, mapMaybe) 20import qualified Data.Set as Set 21import Data.Set (Set) 22 23import Language.Haskell.TH.Datatype 24import Language.Haskell.TH.Lib 25import Language.Haskell.TH.Syntax 26 27#ifndef CURRENT_PACKAGE_KEY 28import Data.Version (showVersion) 29import Paths_invariant (version) 30#endif 31 32------------------------------------------------------------------------------- 33-- Expanding type synonyms 34------------------------------------------------------------------------------- 35 36applySubstitutionKind :: Map Name Kind -> Type -> Type 37#if MIN_VERSION_template_haskell(2,8,0) 38applySubstitutionKind = applySubstitution 39#else 40applySubstitutionKind _ t = t 41#endif 42 43substNameWithKind :: Name -> Kind -> Type -> Type 44substNameWithKind n k = applySubstitutionKind (Map.singleton n k) 45 46substNamesWithKindStar :: [Name] -> Type -> Type 47substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns 48 49------------------------------------------------------------------------------- 50-- Class-specific constants 51------------------------------------------------------------------------------- 52 53-- | A representation of which @Invariant@ is being used. 54data InvariantClass = Invariant | Invariant2 55 deriving (Eq, Ord) 56 57instance Enum InvariantClass where 58 fromEnum Invariant = 1 59 fromEnum Invariant2 = 2 60 61 toEnum 1 = Invariant 62 toEnum 2 = Invariant2 63 toEnum i = error $ "No Invariant class for number " ++ show i 64 65invmapConstName :: InvariantClass -> Name 66invmapConstName Invariant = invmapConstValName 67invmapConstName Invariant2 = invmap2ConstValName 68 69invariantClassName :: InvariantClass -> Name 70invariantClassName Invariant = invariantTypeName 71invariantClassName Invariant2 = invariant2TypeName 72 73invmapName :: InvariantClass -> Name 74invmapName Invariant = invmapValName 75invmapName Invariant2 = invmap2ValName 76 77-- | A type-restricted version of 'const'. This constrains the map functions 78-- that are autogenerated by Template Haskell to be the correct type, even 79-- if they aren't actually used in an invmap(2) expression. This is useful 80-- in makeInvmap(2), since a map function might have its type inferred as 81-- @a@ instead of @a -> b@ (which is clearly wrong). 82invmapConst :: f b -> (a -> b) -> (b -> a) -> f a -> f b 83invmapConst = const . const . const 84{-# INLINE invmapConst #-} 85 86invmap2Const :: f c d 87 -> (a -> c) -> (c -> a) 88 -> (b -> d) -> (d -> b) 89 -> f a b -> f c d 90invmap2Const = const . const . const . const . const 91{-# INLINE invmap2Const #-} 92 93------------------------------------------------------------------------------- 94-- StarKindStatus 95------------------------------------------------------------------------------- 96 97-- | Whether a type is not of kind *, is of kind *, or is a kind variable. 98data StarKindStatus = NotKindStar 99 | KindStar 100 | IsKindVar Name 101 deriving Eq 102 103-- | Does a Type have kind * or k (for some kind variable k)? 104canRealizeKindStar :: Type -> StarKindStatus 105canRealizeKindStar t 106 | hasKindStar t = KindStar 107 | otherwise = case t of 108#if MIN_VERSION_template_haskell(2,8,0) 109 SigT _ (VarT k) -> IsKindVar k 110#endif 111 _ -> NotKindStar 112 113-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. 114-- Otherwise, returns 'Nothing'. 115starKindStatusToName :: StarKindStatus -> Maybe Name 116starKindStatusToName (IsKindVar n) = Just n 117starKindStatusToName _ = Nothing 118 119-- | Concat together all of the StarKindStatuses that are IsKindVar and extract 120-- the kind variables' Names out. 121catKindVarNames :: [StarKindStatus] -> [Name] 122catKindVarNames = mapMaybe starKindStatusToName 123 124------------------------------------------------------------------------------- 125-- Assorted utilities 126------------------------------------------------------------------------------- 127 128-- | Returns True if a Type has kind *. 129hasKindStar :: Type -> Bool 130hasKindStar VarT{} = True 131#if MIN_VERSION_template_haskell(2,8,0) 132hasKindStar (SigT _ StarT) = True 133#else 134hasKindStar (SigT _ StarK) = True 135#endif 136hasKindStar _ = False 137 138-- Returns True is a kind is equal to *, or if it is a kind variable. 139isStarOrVar :: Kind -> Bool 140#if MIN_VERSION_template_haskell(2,8,0) 141isStarOrVar StarT = True 142isStarOrVar VarT{} = True 143#else 144isStarOrVar StarK = True 145#endif 146isStarOrVar _ = False 147 148-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form 149-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or 150-- kind variables. 151hasKindVarChain :: Int -> Type -> Maybe [Name] 152hasKindVarChain kindArrows t = 153 let uk = uncurryKind (tyKind t) 154 in if (length uk - 1 == kindArrows) && all isStarOrVar uk 155 then Just (freeVariables uk) 156 else Nothing 157 158-- | If a Type is a SigT, returns its kind signature. Otherwise, return *. 159tyKind :: Type -> Kind 160tyKind (SigT _ k) = k 161tyKind _ = starK 162 163-- | A mapping of type variable Names to their map function Names. For example, in a 164-- Invariant declaration, a TyVarMap might look like: 165-- 166-- (a ~> (covA, contraA), b ~> (covB, contraB)) 167-- 168-- where a and b are the last two type variables of the datatype, and covA and covB 169-- are the two map functions for a and b in covariant positions, and contraA and 170-- contraB are the two map functions for a and b in contravariant positions. 171type TyVarMap = Map Name (Name, Name) 172 173fst3 :: (a, b, c) -> a 174fst3 (a, _, _) = a 175 176thd3 :: (a, b, c) -> c 177thd3 (_, _, c) = c 178 179-- Like 'lookup', but for lists of triples. 180lookup2 :: Eq a => a -> [(a, b, c)] -> Maybe (b, c) 181lookup2 _ [] = Nothing 182lookup2 key ((x,y,z):xyzs) 183 | key == x = Just (y, z) 184 | otherwise = lookup2 key xyzs 185 186-- | Generate a list of fresh names with a common prefix, and numbered suffixes. 187newNameList :: String -> Int -> Q [Name] 188newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] 189 190createKindChain :: Int -> Kind 191createKindChain = go starK 192 where 193 go :: Kind -> Int -> Kind 194 go k 0 = k 195 go k n = n `seq` go (arrowKCompat starK k) (n - 1) 196 197-- | Applies a typeclass constraint to a type. 198applyClass :: Name -> Name -> Pred 199#if MIN_VERSION_template_haskell(2,10,0) 200applyClass con t = AppT (ConT con) (VarT t) 201#else 202applyClass con t = ClassP con [VarT t] 203#endif 204 205-- | Checks to see if the last types in a data family instance can be safely eta- 206-- reduced (i.e., dropped), given the other types. This checks for three conditions: 207-- 208-- (1) All of the dropped types are type variables 209-- (2) All of the dropped types are distinct 210-- (3) None of the remaining types mention any of the dropped types 211canEtaReduce :: [Type] -> [Type] -> Bool 212canEtaReduce remaining dropped = 213 all isTyVar dropped 214 && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type 215 -- didn't have an Ord instance until template-haskell-2.10.0.0 216 && not (any (`mentionsName` droppedNames) remaining) 217 where 218 droppedNames :: [Name] 219 droppedNames = map varTToName dropped 220 221-- | Extract Just the Name from a type variable. If the argument Type is not a 222-- type variable, return Nothing. 223varTToName_maybe :: Type -> Maybe Name 224varTToName_maybe (VarT n) = Just n 225varTToName_maybe (SigT t _) = varTToName_maybe t 226varTToName_maybe _ = Nothing 227 228-- | Extract the Name from a type variable. If the argument Type is not a 229-- type variable, throw an error. 230varTToName :: Type -> Name 231varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe 232 233-- | Peel off a kind signature from a Type (if it has one). 234unSigT :: Type -> Type 235unSigT (SigT t _) = t 236unSigT t = t 237 238-- | Is the given type a variable? 239isTyVar :: Type -> Bool 240isTyVar (VarT _) = True 241isTyVar (SigT t _) = isTyVar t 242isTyVar _ = False 243 244-- | Detect if a Name in a list of provided Names occurs as an argument to some 245-- type family. This makes an effort to exclude /oversaturated/ arguments to 246-- type families. For instance, if one declared the following type family: 247-- 248-- @ 249-- type family F a :: Type -> Type 250-- @ 251-- 252-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, 253-- but not @b@. 254isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool 255isInTypeFamilyApp names tyFun tyArgs = 256 case tyFun of 257 ConT tcName -> go tcName 258 _ -> return False 259 where 260 go :: Name -> Q Bool 261 go tcName = do 262 info <- reify tcName 263 case info of 264#if MIN_VERSION_template_haskell(2,11,0) 265 FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ 266 -> withinFirstArgs bndrs 267#elif MIN_VERSION_template_haskell(2,7,0) 268 FamilyI (FamilyD TypeFam _ bndrs _) _ 269 -> withinFirstArgs bndrs 270#else 271 TyConI (FamilyD TypeFam _ bndrs _) 272 -> withinFirstArgs bndrs 273#endif 274 275#if MIN_VERSION_template_haskell(2,11,0) 276 FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ 277 -> withinFirstArgs bndrs 278#elif MIN_VERSION_template_haskell(2,9,0) 279 FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ 280 -> withinFirstArgs bndrs 281#endif 282 283 _ -> return False 284 where 285 withinFirstArgs :: [a] -> Q Bool 286 withinFirstArgs bndrs = 287 let firstArgs = take (length bndrs) tyArgs 288 argFVs = freeVariables firstArgs 289 in return $ any (`elem` argFVs) names 290 291-- | Are all of the items in a list (which have an ordering) distinct? 292-- 293-- This uses Set (as opposed to nub) for better asymptotic time complexity. 294allDistinct :: Ord a => [a] -> Bool 295allDistinct = allDistinct' Set.empty 296 where 297 allDistinct' :: Ord a => Set a -> [a] -> Bool 298 allDistinct' uniqs (x:xs) 299 | x `Set.member` uniqs = False 300 | otherwise = allDistinct' (Set.insert x uniqs) xs 301 allDistinct' _ _ = True 302 303-- | Does the given type mention any of the Names in the list? 304mentionsName :: Type -> [Name] -> Bool 305mentionsName = go 306 where 307 go :: Type -> [Name] -> Bool 308 go (AppT t1 t2) names = go t1 names || go t2 names 309 go (SigT t _k) names = go t names 310#if MIN_VERSION_template_haskell(2,8,0) 311 || go _k names 312#endif 313 go (VarT n) names = n `elem` names 314 go _ _ = False 315 316-- | Does an instance predicate mention any of the Names in the list? 317predMentionsName :: Pred -> [Name] -> Bool 318#if MIN_VERSION_template_haskell(2,10,0) 319predMentionsName = mentionsName 320#else 321predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys 322predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names 323#endif 324 325-- | Construct a type via curried application. 326applyTy :: Type -> [Type] -> Type 327applyTy = foldl' AppT 328 329-- | Fully applies a type constructor to its type variables. 330applyTyCon :: Name -> [Type] -> Type 331applyTyCon = applyTy . ConT 332 333-- | Split an applied type into its individual components. For example, this: 334-- 335-- @ 336-- Either Int Char 337-- @ 338-- 339-- would split to this: 340-- 341-- @ 342-- [Either, Int, Char] 343-- @ 344unapplyTy :: Type -> (Type, [Type]) 345unapplyTy ty = go ty ty [] 346 where 347 go :: Type -> Type -> [Type] -> (Type, [Type]) 348 go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) 349 go origTy (SigT ty' _) args = go origTy ty' args 350#if MIN_VERSION_template_haskell(2,11,0) 351 go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args 352 go origTy (ParensT ty') args = go origTy ty' args 353#endif 354 go origTy _ args = (origTy, args) 355 356-- | Split a type signature by the arrows on its spine. For example, this: 357-- 358-- @ 359-- forall a b. (a ~ b) => (a -> b) -> Char -> () 360-- @ 361-- 362-- would split to this: 363-- 364-- @ 365-- (a ~ b, [a -> b, Char, ()]) 366-- @ 367uncurryTy :: Type -> (Cxt, [Type]) 368uncurryTy (AppT (AppT ArrowT t1) t2) = 369 let (ctxt, tys) = uncurryTy t2 370 in (ctxt, t1:tys) 371uncurryTy (SigT t _) = uncurryTy t 372uncurryTy (ForallT _ ctxt t) = 373 let (ctxt', tys) = uncurryTy t 374 in (ctxt ++ ctxt', tys) 375uncurryTy t = ([], [t]) 376 377-- | Like uncurryType, except on a kind level. 378uncurryKind :: Kind -> [Kind] 379#if MIN_VERSION_template_haskell(2,8,0) 380uncurryKind = snd . uncurryTy 381#else 382uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 383uncurryKind k = [k] 384#endif 385 386------------------------------------------------------------------------------- 387-- Manually quoted names 388------------------------------------------------------------------------------- 389 390-- By manually generating these names we avoid needing to use the 391-- TemplateHaskell language extension when compiling the invariant library. 392-- This allows the library to be used in stage1 cross-compilers. 393 394invariantPackageKey :: String 395#ifdef CURRENT_PACKAGE_KEY 396invariantPackageKey = CURRENT_PACKAGE_KEY 397#else 398invariantPackageKey = "invariant-" ++ showVersion version 399#endif 400 401mkInvariantName_tc :: String -> String -> Name 402mkInvariantName_tc = mkNameG_tc invariantPackageKey 403 404mkInvariantName_v :: String -> String -> Name 405mkInvariantName_v = mkNameG_v invariantPackageKey 406 407invariantTypeName :: Name 408invariantTypeName = mkInvariantName_tc "Data.Functor.Invariant" "Invariant" 409 410invariant2TypeName :: Name 411invariant2TypeName = mkInvariantName_tc "Data.Functor.Invariant" "Invariant2" 412 413invmapValName :: Name 414invmapValName = mkInvariantName_v "Data.Functor.Invariant" "invmap" 415 416invmap2ValName :: Name 417invmap2ValName = mkInvariantName_v "Data.Functor.Invariant" "invmap2" 418 419invmapConstValName :: Name 420invmapConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmapConst" 421 422invmap2ConstValName :: Name 423invmap2ConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmap2Const" 424 425coerceValName :: Name 426coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" 427 428errorValName :: Name 429errorValName = mkNameG_v "base" "GHC.Err" "error" 430 431seqValName :: Name 432seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" 433