{-# LANGUAGE CPP #-}
module Language.Haskell.TH.ReifyMany where
import qualified Control.Monad.State as State
import Data.Maybe (isNothing)
import qualified Data.Set as S
import Language.Haskell.TH
import Language.Haskell.TH.ReifyMany.Internal
reifyManyWithoutInstances :: Name -> [Name] -> (Name -> Bool) -> Q [Name]
reifyManyWithoutInstances :: Name -> [Name] -> (Name -> Bool) -> Q [Name]
reifyManyWithoutInstances Name
clz [Name]
initial Name -> Bool
recursePred = do
[TypeclassInstance]
insts <- Name -> Q [TypeclassInstance]
getInstances Name
clz
let recurse :: (Name, Dec) -> m (Bool, [Name])
recurse (Name
name, Dec
dec)
| Name -> Bool
recursePred Name
name Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing ([TypeclassInstance] -> Name -> Maybe TypeclassInstance
lookupInstance [TypeclassInstance]
insts Name
name) = do
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Bool
isDataDec Dec
dec, Dec -> [Name]
decConcreteNames Dec
dec)
recurse (Name, Dec)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
[(Name, Info)]
infos <- ((Name, Dec) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)]
reifyManyTyCons forall {m :: * -> *}. Monad m => (Name, Dec) -> m (Bool, [Name])
recurse [Name]
initial
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, Info)]
infos)
reifyManyTyCons :: ((Name, Dec) -> Q (Bool, [Name]))
-> [Name]
-> Q [(Name, Info)]
reifyManyTyCons :: ((Name, Dec) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)]
reifyManyTyCons (Name, Dec) -> Q (Bool, [Name])
recurse = ((Name, Info) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)]
reifyMany (Name, Info) -> Q (Bool, [Name])
recurse'
where
recurse' :: (Name, Info) -> Q (Bool, [Name])
recurse' (Name
name, Info
info) = do
let skip :: p -> m (Bool, [a])
skip p
_ = do
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
unexpected :: [Char] -> m a
unexpected [Char]
thing = do
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"reifyManyTyCons encountered unexpected " forall a. [a] -> [a] -> [a]
++ [Char]
thing forall a. [a] -> [a] -> [a]
++ [Char]
" named " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> [Char]
pprint Name
name
case Info
info of
TyConI Dec
dec -> (Name, Dec) -> Q (Bool, [Name])
recurse (Name
name, Dec
dec)
PrimTyConI{} -> forall {m :: * -> *} {p} {a}. Monad m => p -> m (Bool, [a])
skip [Char]
"prim type constructor"
DataConI{} -> forall {m :: * -> *} {p} {a}. Monad m => p -> m (Bool, [a])
skip [Char]
"data constructor"
ClassI{} -> forall {m :: * -> *} {p} {a}. Monad m => p -> m (Bool, [a])
skip [Char]
"class"
ClassOpI{} -> forall {m :: * -> *} {a}. MonadFail m => [Char] -> m a
unexpected [Char]
"class method"
VarI{} -> forall {m :: * -> *} {a}. MonadFail m => [Char] -> m a
unexpected [Char]
"value variable"
TyVarI{} -> forall {m :: * -> *} {a}. MonadFail m => [Char] -> m a
unexpected [Char]
"type variable"
#if MIN_VERSION_template_haskell(2,7,0)
FamilyI{} -> forall {m :: * -> *} {p} {a}. Monad m => p -> m (Bool, [a])
skip [Char]
"type or data family"
#endif
#if MIN_VERSION_template_haskell(2,12,0)
PatSynI{} -> forall {m :: * -> *} {p} {a}. Monad m => p -> m (Bool, [a])
skip [Char]
"pattern synonym"
#endif
reifyMany :: ((Name, Info) -> Q (Bool, [Name]))
-> [Name]
-> Q [(Name, Info)]
reifyMany :: ((Name, Info) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)]
reifyMany (Name, Info) -> Q (Bool, [Name])
recurse [Name]
initial =
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> StateT (Set Name) Q [(Name, Info)]
go [Name]
initial) forall a. Set a
S.empty
where
go :: Name -> State.StateT (S.Set Name) Q [(Name, Info)]
go :: Name -> StateT (Set Name) Q [(Name, Info)]
go Name
n = do
Set Name
seen <- forall s (m :: * -> *). MonadState s m => m s
State.get
if forall a. Ord a => a -> Set a -> Bool
S.member Name
n Set Name
seen
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (forall a. Ord a => a -> Set a -> Set a
S.insert Name
n Set Name
seen)
Info
info <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift (Name -> Q Info
reify Name
n)
(Bool
shouldEmit, [Name]
ns) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift forall a b. (a -> b) -> a -> b
$ (Name, Info) -> Q (Bool, [Name])
recurse (Name
n, Info
info)
[(Name, Info)]
results <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> StateT (Set Name) Q [(Name, Info)]
go [Name]
ns
if Bool
shouldEmit
then forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n, Info
info) forall a. a -> [a] -> [a]
: [(Name, Info)]
results)
else forall (m :: * -> *) a. Monad m => a -> m a
return [(Name, Info)]
results