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-- | Is the given type a type family constructor (and not a data family constructor)? 245isTyFamily :: Type -> Q Bool 246isTyFamily (ConT n) = do 247 info <- reify n 248 return $ case info of 249#if MIN_VERSION_template_haskell(2,11,0) 250 FamilyI OpenTypeFamilyD{} _ -> True 251#elif MIN_VERSION_template_haskell(2,7,0) 252 FamilyI (FamilyD TypeFam _ _ _) _ -> True 253#else 254 TyConI (FamilyD TypeFam _ _ _) -> True 255#endif 256#if MIN_VERSION_template_haskell(2,9,0) 257 FamilyI ClosedTypeFamilyD{} _ -> True 258#endif 259 _ -> False 260isTyFamily _ = return False 261 262-- | Are all of the items in a list (which have an ordering) distinct? 263-- 264-- This uses Set (as opposed to nub) for better asymptotic time complexity. 265allDistinct :: Ord a => [a] -> Bool 266allDistinct = allDistinct' Set.empty 267 where 268 allDistinct' :: Ord a => Set a -> [a] -> Bool 269 allDistinct' uniqs (x:xs) 270 | x `Set.member` uniqs = False 271 | otherwise = allDistinct' (Set.insert x uniqs) xs 272 allDistinct' _ _ = True 273 274-- | Does the given type mention any of the Names in the list? 275mentionsName :: Type -> [Name] -> Bool 276mentionsName = go 277 where 278 go :: Type -> [Name] -> Bool 279 go (AppT t1 t2) names = go t1 names || go t2 names 280 go (SigT t _k) names = go t names 281#if MIN_VERSION_template_haskell(2,8,0) 282 || go _k names 283#endif 284 go (VarT n) names = n `elem` names 285 go _ _ = False 286 287-- | Does an instance predicate mention any of the Names in the list? 288predMentionsName :: Pred -> [Name] -> Bool 289#if MIN_VERSION_template_haskell(2,10,0) 290predMentionsName = mentionsName 291#else 292predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys 293predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names 294#endif 295 296-- | Construct a type via curried application. 297applyTy :: Type -> [Type] -> Type 298applyTy = foldl' AppT 299 300-- | Fully applies a type constructor to its type variables. 301applyTyCon :: Name -> [Type] -> Type 302applyTyCon = applyTy . ConT 303 304-- | Split an applied type into its individual components. For example, this: 305-- 306-- @ 307-- Either Int Char 308-- @ 309-- 310-- would split to this: 311-- 312-- @ 313-- [Either, Int, Char] 314-- @ 315unapplyTy :: Type -> [Type] 316unapplyTy = reverse . go 317 where 318 go :: Type -> [Type] 319 go (AppT t1 t2) = t2:go t1 320 go (SigT t _) = go t 321 go (ForallT _ _ t) = go t 322 go t = [t] 323 324-- | Split a type signature by the arrows on its spine. For example, this: 325-- 326-- @ 327-- forall a b. (a ~ b) => (a -> b) -> Char -> () 328-- @ 329-- 330-- would split to this: 331-- 332-- @ 333-- (a ~ b, [a -> b, Char, ()]) 334-- @ 335uncurryTy :: Type -> (Cxt, [Type]) 336uncurryTy (AppT (AppT ArrowT t1) t2) = 337 let (ctxt, tys) = uncurryTy t2 338 in (ctxt, t1:tys) 339uncurryTy (SigT t _) = uncurryTy t 340uncurryTy (ForallT _ ctxt t) = 341 let (ctxt', tys) = uncurryTy t 342 in (ctxt ++ ctxt', tys) 343uncurryTy t = ([], [t]) 344 345-- | Like uncurryType, except on a kind level. 346uncurryKind :: Kind -> [Kind] 347#if MIN_VERSION_template_haskell(2,8,0) 348uncurryKind = snd . uncurryTy 349#else 350uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 351uncurryKind k = [k] 352#endif 353 354------------------------------------------------------------------------------- 355-- Manually quoted names 356------------------------------------------------------------------------------- 357 358-- By manually generating these names we avoid needing to use the 359-- TemplateHaskell language extension when compiling the invariant library. 360-- This allows the library to be used in stage1 cross-compilers. 361 362invariantPackageKey :: String 363#ifdef CURRENT_PACKAGE_KEY 364invariantPackageKey = CURRENT_PACKAGE_KEY 365#else 366invariantPackageKey = "invariant-" ++ showVersion version 367#endif 368 369mkInvariantName_tc :: String -> String -> Name 370mkInvariantName_tc = mkNameG_tc invariantPackageKey 371 372mkInvariantName_v :: String -> String -> Name 373mkInvariantName_v = mkNameG_v invariantPackageKey 374 375invariantTypeName :: Name 376invariantTypeName = mkInvariantName_tc "Data.Functor.Invariant" "Invariant" 377 378invariant2TypeName :: Name 379invariant2TypeName = mkInvariantName_tc "Data.Functor.Invariant" "Invariant2" 380 381invmapValName :: Name 382invmapValName = mkInvariantName_v "Data.Functor.Invariant" "invmap" 383 384invmap2ValName :: Name 385invmap2ValName = mkInvariantName_v "Data.Functor.Invariant" "invmap2" 386 387invmapConstValName :: Name 388invmapConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmapConst" 389 390invmap2ConstValName :: Name 391invmap2ConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmap2Const" 392 393coerceValName :: Name 394coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" 395 396errorValName :: Name 397errorValName = mkNameG_v "base" "GHC.Err" "error" 398 399seqValName :: Name 400seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" 401 402#if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0)) 403starKindName :: Name 404starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" 405#endif 406