#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
#endif
module Language.Haskell.TH.Lens
( HasName(..)
, HasTypeVars(..)
, SubstType(..)
, typeVars
, substTypeVars
, conFields
, conNamedFields
) where
import Control.Applicative
import Control.Lens.Getter
import Control.Lens.Setter
import Control.Lens.Fold
import Control.Lens.Type
import Control.Lens.Traversal
import Control.Lens.IndexedLens
import Data.Map as Map hiding (toList,map)
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Set as Set hiding (toList,map)
import Data.Set.Lens
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
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 `Set.union` setOf typeVars 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)
where m' = foldrOf typeVars Map.delete m bs
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)
conFields :: Simple Traversal Con StrictType
conFields f (NormalC n fs) = NormalC n <$> traverse f fs
conFields f (RecC n fs) = RecC n <$> traverse sans_var fs
where sans_var (fn,s,t) = (\(s', t') -> (fn,s',t')) <$> f (s, t)
conFields f (InfixC l n r) = InfixC <$> f l <*> pure n <*> f r
conFields f (ForallC bds ctx c) = ForallC bds ctx <$> conFields f c
conNamedFields :: Simple Traversal Con VarStrictType
conNamedFields f (RecC n fs) = RecC n <$> traverse f fs
conNamedFields _ c = pure c