{-# 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
insts <- Name -> Q [TypeclassInstance]
getInstances Name
clz
let recurse (Name
name, Dec
dec)
| Name -> Bool
recursePred Name
name Bool -> Bool -> Bool
&& Maybe TypeclassInstance -> Bool
forall a. Maybe a -> Bool
isNothing ([TypeclassInstance] -> Name -> Maybe TypeclassInstance
lookupInstance [TypeclassInstance]
insts Name
name) = do
(Bool, [Name]) -> m (Bool, [Name])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Bool
isDataDec Dec
dec, Dec -> [Name]
decConcreteNames Dec
dec)
recurse (Name, Dec)
_ = (Bool, [Name]) -> m (Bool, [Name])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
infos <- reifyManyTyCons recurse initial
return (map fst 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
(Bool, [a]) -> m (Bool, [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
unexpected :: [Char] -> m a
unexpected [Char]
thing = do
[Char] -> m a
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char]
"reifyManyTyCons encountered unexpected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
thing [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" named " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
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{} -> [Char] -> Q (Bool, [Name])
forall {m :: * -> *} {p} {a}. Monad m => p -> m (Bool, [a])
skip [Char]
"prim type constructor"
DataConI{} -> [Char] -> Q (Bool, [Name])
forall {m :: * -> *} {p} {a}. Monad m => p -> m (Bool, [a])
skip [Char]
"data constructor"
ClassI{} -> [Char] -> Q (Bool, [Name])
forall {m :: * -> *} {p} {a}. Monad m => p -> m (Bool, [a])
skip [Char]
"class"
ClassOpI{} -> [Char] -> Q (Bool, [Name])
forall {m :: * -> *} {a}. MonadFail m => [Char] -> m a
unexpected [Char]
"class method"
VarI{} -> [Char] -> Q (Bool, [Name])
forall {m :: * -> *} {a}. MonadFail m => [Char] -> m a
unexpected [Char]
"value variable"
TyVarI{} -> [Char] -> Q (Bool, [Name])
forall {m :: * -> *} {a}. MonadFail m => [Char] -> m a
unexpected [Char]
"type variable"
#if MIN_VERSION_template_haskell(2,7,0)
FamilyI{} -> [Char] -> Q (Bool, [Name])
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{} -> [Char] -> Q (Bool, [Name])
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 =
StateT (Set Name) Q [(Name, Info)] -> Set Name -> Q [(Name, Info)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT (([[(Name, Info)]] -> [(Name, Info)])
-> StateT (Set Name) Q [[(Name, Info)]]
-> StateT (Set Name) Q [(Name, Info)]
forall a b.
(a -> b) -> StateT (Set Name) Q a -> StateT (Set Name) Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Name, Info)]] -> [(Name, Info)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (StateT (Set Name) Q [[(Name, Info)]]
-> StateT (Set Name) Q [(Name, Info)])
-> StateT (Set Name) Q [[(Name, Info)]]
-> StateT (Set Name) Q [(Name, Info)]
forall a b. (a -> b) -> a -> b
$ (Name -> StateT (Set Name) Q [(Name, Info)])
-> [Name] -> StateT (Set Name) Q [[(Name, Info)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> StateT (Set Name) Q [(Name, Info)]
go [Name]
initial) Set Name
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
seen <- StateT (Set Name) Q (Set Name)
forall s (m :: * -> *). MonadState s m => m s
State.get
if S.member n seen
then return []
else do
State.put (S.insert n seen)
info <- State.lift (reify n)
(shouldEmit, ns) <- State.lift $ recurse (n, info)
results <- fmap concat $ mapM go ns
if shouldEmit
then return ((n, info) : results)
else return results