{-# 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
&& 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, [])
[(Name, Info)]
infos <- ((Name, Dec) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)]
reifyManyTyCons (Name, Dec) -> Q (Bool, [Name])
forall {m :: * -> *}. Monad m => (Name, Dec) -> m (Bool, [Name])
recurse [Name]
initial
[Name] -> Q [Name]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (((Name, Info) -> Name) -> [(Name, Info)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Info) -> Name
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
(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
Set Name
seen <- StateT (Set Name) Q (Set Name)
forall s (m :: * -> *). MonadState s m => m s
State.get
if Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Name
n Set Name
seen
then [(Name, Info)] -> StateT (Set Name) Q [(Name, Info)]
forall a. a -> StateT (Set Name) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
Set Name -> StateT (Set Name) Q ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
S.insert Name
n Set Name
seen)
Info
info <- Q Info -> StateT (Set Name) Q Info
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
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) <- Q (Bool, [Name]) -> StateT (Set Name) Q (Bool, [Name])
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift (Q (Bool, [Name]) -> StateT (Set Name) Q (Bool, [Name]))
-> Q (Bool, [Name]) -> StateT (Set Name) Q (Bool, [Name])
forall a b. (a -> b) -> a -> b
$ (Name, Info) -> Q (Bool, [Name])
recurse (Name
n, Info
info)
[(Name, Info)]
results <- ([[(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]
ns
if Bool
shouldEmit
then [(Name, Info)] -> StateT (Set Name) Q [(Name, Info)]
forall a. a -> StateT (Set Name) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n, Info
info) (Name, Info) -> [(Name, Info)] -> [(Name, Info)]
forall a. a -> [a] -> [a]
: [(Name, Info)]
results)
else [(Name, Info)] -> StateT (Set Name) Q [(Name, Info)]
forall a. a -> StateT (Set Name) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name, Info)]
results