module Language.Haskell.TH.Lens
( HasName(..)
, HasTypeVars(..)
, SubstType(..)
, typeVars
, substTypeVars
) where
import Control.Applicative
import Control.Lens
import Data.Map as Map hiding (toList,map)
import Data.Map.Lens
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Set as Set hiding (toList,map)
import Data.Set.Lens
import Language.Haskell.TH
class HasName t where
name :: Simple Lens t Name
instance HasName TyVarBndr where
name f (PlainTV n) = PlainTV <$> f n
name f (KindedTV n k) = (`KindedTV` k) <$> f n
instance HasName Name where
name = id
instance HasName Con where
name f (NormalC n tys) = (`NormalC` tys) <$> f n
name f (RecC n tys) = (`RecC` tys) <$> f n
name f (InfixC l n r) = (\n' -> InfixC l n' r) <$> f n
name f (ForallC bds ctx con) = ForallC bds ctx <$> name f con
class HasTypeVars t where
typeVarsEx :: Set Name -> Simple Traversal t Name
instance HasTypeVars TyVarBndr where
typeVarsEx s f b
| s^.contains (b^.name) = pure b
| otherwise = name f b
instance HasTypeVars Name where
typeVarsEx s f n
| s^.contains n = pure n
| otherwise = f n
instance HasTypeVars Type where
typeVarsEx s f (VarT n) = VarT <$> typeVarsEx s f n
typeVarsEx s f (AppT l r) = AppT <$> typeVarsEx s f l <*> typeVarsEx s f r
typeVarsEx s f (SigT t k) = (`SigT` k) <$> typeVarsEx s f t
typeVarsEx s f (ForallT bs ctx ty) = ForallT bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f ty
where s' = s <> foldMapOf typeVars Set.singleton bs
typeVarsEx _ _ t = pure t
instance HasTypeVars Pred where
typeVarsEx s f (ClassP n ts) = ClassP n <$> typeVarsEx s f ts
typeVarsEx s f (EqualP l r) = EqualP <$> typeVarsEx s f l <*> typeVarsEx s f r
instance HasTypeVars t => HasTypeVars [t] where
typeVarsEx s = traverse . typeVarsEx s
typeVars :: HasTypeVars t => Simple Traversal t Name
typeVars = typeVarsEx mempty
substTypeVars :: HasTypeVars t => Map Name Name -> t -> t
substTypeVars m = mapOf typeVars $ \n -> fromMaybe n (m^.at n)
class SubstType t where
substType :: Map Name Type -> t -> t
instance SubstType Type where
substType m t@(VarT n) = fromMaybe t (m^.at n)
substType m (ForallT bs ctx ty) = ForallT bs (substType m ctx) (substType m ty)
substType m (SigT t k) = SigT (substType m t) k
substType m (AppT l r) = AppT (substType m l) (substType m r)
substType _ t = t
instance SubstType t => SubstType [t] where
substType = map . substType
instance SubstType Pred where
substType m (ClassP n ts) = ClassP n (substType m ts)
substType m (EqualP l r) = substType m (EqualP l r)