{-# LANGUAGE CPP #-}
-- | @th-reify-many@ provides functions for recursively reifying top
-- level declarations.  The main intended use case is for enumerating
-- the names of datatypes reachable from an initial datatype, and
-- passing these names to some function which generates instances.
--
-- For example, in order to define 'Language.Haskell.TH.Syntax.Lift'
-- instances for two mutually recursive datatypes, I could write
-- something like:
--
-- > {-# LANGUAGE TemplateHaskell #-}
-- > import Language.Haskell.TH.ReifyMany (reifyManyWithoutInstances)
-- > import Language.Haskell.TH.Lift (Lift(..), deriveLiftMany)
-- >
-- > data A = A B
-- >
-- > data B = B Int
-- >
-- > $(reifyManyWithoutInstances ''Lift [''A] (const True) >>= deriveLiftMany)
--
-- One interesting feature of this is that it attempts to omit the
-- types which already have an instance defined.  For example, if
-- @$(deriveLift ''B)@ is used before @deriveLiftMany@, it will omit
-- the instance for B.
--
-- Of course, the intended usecase for this involves many more
-- datatypes - for example, syntax trees such as those found in TH.
--
-- Note that 'reifyManyWithoutInstances' is rather imperfect in its
-- testing of whether an instance exists, and whether an instance
-- should exist.  See this function's docs for details.
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

-- | Recursively enumerates type constructor declarations, halting
-- when datatypes appear to already have an instance for the typeclass
-- specified by the first 'Name' parameter.  It guesses that an
-- instance exists for a given datatype if it's used in the top
-- constructor of any of its parameters (see 'instanceMatches').
--
-- This function is useful for bulk defining typeclass instances like
-- @Binary@, @Lift@, @Data@, @Typeable@, etc.  It isn't very clever,
-- though - in particular it has the following limitations:
--
-- * It only works well when type constructors mentioned in
--   fields should all have instances defined for them.
--
-- * It ignores data type / constructor constraints.
--
-- * It ignores data / type families.
--
-- It also takes a user-defined predicate, which is useful in
-- situations where this attempts to descend into datatypes which do
-- not need instances defined for them.
--
-- Note that this will always initially yield the 'Name's of the
-- initial types, regardless of whether they are instances or not.
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 (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 (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)

-- | Like 'reifyMany', but specialized for recursively enumerating
-- type constructor declarations, omitting 'PrimTyConI'.
--
-- In order to have this behave like 'reifyManyWithoutInstances', but
-- not do any instance filtering, use it with the 'isDataDec' and
-- 'decConcreteNames' internal utilities.  For example:
--
-- > {-# LANGUAGE TemplateHaskell #-}
-- > import Language.Haskell.TH
-- > import Language.Haskell.TH.ReifyMany
-- > import Language.Haskell.TH.ReifyMany.Internal
-- >
-- > $(do results <- reifyManyTyCons
-- >          (\(_, dec) -> return (isDataDec dec, decConcreteNames dec))
-- >          [''Exp]
-- >      -- Display the results
-- >      reportError (show (map fst results))
-- >      -- This TH splice doesn't generate any code.
-- >      return []
-- >  )
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 (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
            unexpected :: [Char] -> m a
unexpected [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
$ [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

-- | Starting from a set of initial top level declarations, specified
-- by @[Name]@, recursively enumerate other related declarations.  The
-- provided function determines whether the current info be included
-- in the list of results, and which 'Name's to lookup next. This
-- function handles keeping track of which 'Name's have already been
-- visited.
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 (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 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)
                (Bool
shouldEmit, [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

-- | Like 'getDatatypesWithoutInstanceOf', but more precise as it uses
-- the 'isInstance' function
--
-- The typeclass is specified by a 'Name', and a function
-- to take the concrete type to a list of the parameters for the
-- typeclass.
--
-- FIXME: this code is disabled because "isInstance" doesn't do any
-- recursive instance resolution.  For example, it yields 'True' when
-- asked if the instance (Show [Int -> Int]) exists, since one exists
-- for lists.
{-
getDataTypesWithoutInstancesOf' :: Name -> (Type -> [Type]) -> Name -> (Name -> Bool) -> Q [Name]
getDataTypesWithoutInstancesOf' clz tysFunc initial recursePred = do
    let recurse (name, dec)
            | recursePred name && isNormalTyCon dec = do
                let tys = concat (decToFieldTypes dec)
                reportError ("before: " ++ show tys)
                filtered <- filterM (fmap not . recover (return True) . isInstance clz . tysFunc) tys
                State.when (not (null filtered)) $ reportError (show filtered)
                return (isDataDec dec, concatMap typeConcreteNames filtered)
        recurse _ = return (False, [])
    infos <- reifyManyTyCons recurse initial
    return (map fst infos)
-}