{-# 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 clz :: Name
clz initial :: [Name]
initial recursePred :: Name -> Bool
recursePred = do
[TypeclassInstance]
insts <- Name -> Q [TypeclassInstance]
getInstances Name
clz
let recurse :: (Name, Dec) -> m (Bool, [Name])
recurse (name :: Name
name, dec :: 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 (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Bool
isDataDec Dec
dec, Dec -> [Name]
decConcreteNames Dec
dec)
recurse _ = (Bool, [Name]) -> m (Bool, [Name])
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 (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 recurse :: (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
name, info :: Info
info) = do
let skip :: p -> m (Bool, [a])
skip _ = do
(Bool, [a]) -> m (Bool, [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
unexpected :: [Char] -> m a
unexpected thing :: [Char]
thing = do
[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
$ "reifyManyTyCons encountered unexpected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
thing [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ " 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
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 "prim type constructor"
DataConI{} -> [Char] -> Q (Bool, [Name])
forall (m :: * -> *) p a. Monad m => p -> m (Bool, [a])
skip "data constructor"
ClassI{} -> [Char] -> Q (Bool, [Name])
forall (m :: * -> *) p a. Monad m => p -> m (Bool, [a])
skip "class"
ClassOpI{} -> [Char] -> Q (Bool, [Name])
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
unexpected "class method"
VarI{} -> [Char] -> Q (Bool, [Name])
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
unexpected "value variable"
TyVarI{} -> [Char] -> Q (Bool, [Name])
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
unexpected "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 "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 "pattern synonym"
#endif
reifyMany :: ((Name, Info) -> Q (Bool, [Name]))
-> [Name]
-> Q [(Name, Info)]
reifyMany :: ((Name, Info) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)]
reifyMany recurse :: (Name, Info) -> Q (Bool, [Name])
recurse initial :: [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 (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)
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 n :: 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 (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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift (Name -> Q Info
reify Name
n)
(shouldEmit :: Bool
shouldEmit, ns :: [Name]
ns) <- Q (Bool, [Name]) -> StateT (Set Name) Q (Bool, [Name])
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 (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)
mapM Name -> StateT (Set Name) Q [(Name, Info)]
go [Name]
ns
if Bool
shouldEmit
then [(Name, Info)] -> StateT (Set Name) Q [(Name, Info)]
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 (m :: * -> *) a. Monad m => a -> m a
return [(Name, Info)]
results