    {-# LANGUAGE CPP #-}
    module Language.Haskell.TH.ReifyMany.Internal where

    #if !(MIN_VERSION_template_haskell(2,7,0))
    import Data.List (foldl')
    #endif
    import Data.Maybe (catMaybes)
    import Language.Haskell.TH
    import Language.Haskell.TH.ExpandSyns (expandSyns)
    import Safe (headMay, tailMay)

    -- | Returns 'True' if the 'Dec' is a 'DataD' or 'NewtypeD'
    isDataDec :: Dec -> Bool
    isDataDec :: Dec -> Bool
    isDataDec DataD {} = Bool
    True
    isDataDec NewtypeD {} = Bool
    True
    isDataDec Dec
    _ = Bool
    False

    -- | Returns 'True' if the 'Dec' is a 'DataD', 'NewtypeD', or
    -- 'TySynD'.
    isNormalTyCon :: Dec -> Bool
    isNormalTyCon :: Dec -> Bool
    isNormalTyCon DataD {} = Bool
    True
    isNormalTyCon NewtypeD {} = Bool
    True
    isNormalTyCon TySynD {} = Bool
    True
    isNormalTyCon Dec
    _ = Bool
    False

    -- | For data, newtype, and type declarations, yields a list of the
    -- types of the fields.  In the case of a type synonyms, it just
    -- returns the body of the type synonym as a singleton list.
    decToFieldTypes :: Dec -> [[Type]]
    #if MIN_VERSION_template_haskell(2,11,0)
    decToFieldTypes :: Dec -> [[Type]]
    decToFieldTypes (DataD [Type]
    _ Name
    _ [TyVarBndr BndrVis]
    _ Maybe Type
    _ [Con]
    cons [DerivClause]
    _) = (Con -> [Type]) -> [Con] -> [[Type]]
    forall a b. (a -> b) -> [a] -> [b]
    map Con -> [Type]
    conToFieldTypes [Con]
    cons
    decToFieldTypes (NewtypeD [Type]
    _ Name
    _ [TyVarBndr BndrVis]
    _ Maybe Type
    _ Con
    con [DerivClause]
    _) = [Con -> [Type]
    conToFieldTypes Con
    con]
    #else
    decToFieldTypes (DataD _ _ _ cons _) = map conToFieldTypes cons
    decToFieldTypes (NewtypeD _ _ _ con _) = [conToFieldTypes con]
    #endif
    decToFieldTypes (TySynD Name
    _ [TyVarBndr BndrVis]
    _ Type
    ty) = [[Type
    ty]]
    decToFieldTypes Dec
    _ = []

    -- | Returns the types of the fields of the constructor.
    conToFieldTypes :: Con -> [Type]
    conToFieldTypes :: Con -> [Type]
    conToFieldTypes (NormalC Name
    _ [BangType]
    xs) = (BangType -> Type) -> [BangType] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map BangType -> Type
    forall a b. (a, b) -> b
    snd [BangType]
    xs
    conToFieldTypes (RecC Name
    _ [VarBangType]
    xs) = (VarBangType -> Type) -> [VarBangType] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name
    _, Bang
    _, Type
    ty) -> Type
    ty) [VarBangType]
    xs
    conToFieldTypes (InfixC (Bang
    _, Type
    ty1) Name
    _ (Bang
    _, Type
    ty2)) = [Type
    ty1, Type
    ty2]
    conToFieldTypes (ForallC [TyVarBndr Specificity]
    _ [Type]
    _ Con
    con) = Con -> [Type]
    conToFieldTypes Con
    con
    #if MIN_VERSION_template_haskell(2,11,0)
    conToFieldTypes (GadtC [Name]
    _ [BangType]
    xs Type
    _) = (BangType -> Type) -> [BangType] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map BangType -> Type
    forall a b. (a, b) -> b
    snd [BangType]
    xs
    conToFieldTypes (RecGadtC [Name]
    _ [VarBangType]
    xs Type
    _) = (VarBangType -> Type) -> [VarBangType] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name
    _, Bang
    _, Type
    ty) -> Type
    ty) [VarBangType]
    xs
    #endif

    -- | Returns the names of all type constructors which aren't involved
    -- in constraints.
    typeConcreteNames :: Type -> [Name]
    typeConcreteNames :: Type -> [Name]
    typeConcreteNames (ForallT [TyVarBndr Specificity]
    _ [Type]
    _ Type
    ty) = Type -> [Name]
    typeConcreteNames Type
    ty
    typeConcreteNames (AppT Type
    l Type
    r) = Type -> [Name]
    typeConcreteNames Type
    l [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ Type -> [Name]
    typeConcreteNames Type
    r
    typeConcreteNames (SigT Type
    ty Type
    _) = Type -> [Name]
    typeConcreteNames Type
    ty
    typeConcreteNames (ConT Name
    n) = [Name
    n]
    typeConcreteNames Type
    _ = []

    -- | Returns the names of all type constructors used when defining
    -- type constructors.
    decConcreteNames :: Dec -> [Name]
    decConcreteNames :: Dec -> [Name]
    decConcreteNames = ([Type] -> [Name]) -> [[Type]] -> [Name]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ((Type -> [Name]) -> [Type] -> [Name]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Type -> [Name]
    typeConcreteNames) ([[Type]] -> [Name]) -> (Dec -> [[Type]]) -> Dec -> [Name]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Dec -> [[Type]]
    decToFieldTypes

    -- | Datatype to capture the fields of 'InstanceD'.
    data TypeclassInstance = TypeclassInstance Cxt Type [Dec]
        deriving Int -> TypeclassInstance -> ShowS
    [TypeclassInstance] -> ShowS
    TypeclassInstance -> String
    (Int -> TypeclassInstance -> ShowS)
    -> (TypeclassInstance -> String)
    -> ([TypeclassInstance] -> ShowS)
    -> Show TypeclassInstance
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> TypeclassInstance -> ShowS
    showsPrec :: Int -> TypeclassInstance -> ShowS
    $cshow :: TypeclassInstance -> String
    show :: TypeclassInstance -> String
    $cshowList :: [TypeclassInstance] -> ShowS
    showList :: [TypeclassInstance] -> ShowS
    Show

    -- | Given the 'Name' of a class, yield all of the
    -- 'TypeclassInstance's, with synonyms expanded in the 'Type' field.
    getInstances :: Name -> Q [TypeclassInstance]
    getInstances :: Name -> Q [TypeclassInstance]
    getInstances Name
    clz = do
        res <- Name -> Q Info
    reify Name
    clz
        case res of
            ClassI Dec
    _ [Dec]
    xs -> ([Maybe TypeclassInstance] -> [TypeclassInstance])
    -> Q [Maybe TypeclassInstance] -> Q [TypeclassInstance]
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [Maybe TypeclassInstance] -> [TypeclassInstance]
    forall a. [Maybe a] -> [a]
    catMaybes (Q [Maybe TypeclassInstance] -> Q [TypeclassInstance])
    -> Q [Maybe TypeclassInstance] -> Q [TypeclassInstance]
    forall a b. (a -> b) -> a -> b
    $ (Dec -> Q (Maybe TypeclassInstance))
    -> [Dec] -> Q [Maybe TypeclassInstance]
    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 Dec -> Q (Maybe TypeclassInstance)
    convertDec [Dec]
    xs
            Info
    _ -> String -> Q [TypeclassInstance]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q [TypeclassInstance])
    -> String -> Q [TypeclassInstance]
    forall a b. (a -> b) -> a -> b
    $ String
    "Error in getInstances: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Show a => a -> String
    show Name
    clz String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " isn't a class"
      where
    #if MIN_VERSION_template_haskell(2,7,0)
    #if MIN_VERSION_template_haskell(2,11,0)
        convertDec :: Dec -> Q (Maybe TypeclassInstance)
    convertDec (InstanceD Maybe Overlap
    _ [Type]
    ctxt Type
    typ [Dec]
    decs) = do
    #else
        convertDec (InstanceD ctxt typ decs) = do
    #endif
            typ' <- Type -> Q Type
    expandSyns Type
    typ
            return $ Just (TypeclassInstance ctxt typ' decs)
        convertDec Dec
    _ = Maybe TypeclassInstance -> Q (Maybe TypeclassInstance)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe TypeclassInstance
    forall a. Maybe a
    Nothing
    #else
        convertDec (ClassInstance _ _ ctxt _ typs) = do
            let typ = foldl' AppT (ConT clz) typs
            typ' <- expandSyns typ
            return $ Just (TypeclassInstance ctxt typ' [])
    #endif

    -- | Returns the first 'TypeclassInstance' where 'instanceMatches'
    -- returns true.
    lookupInstance :: [TypeclassInstance] -> Name -> Maybe TypeclassInstance
    lookupInstance :: [TypeclassInstance] -> Name -> Maybe TypeclassInstance
    lookupInstance [TypeclassInstance]
    xs Name
    n = [TypeclassInstance] -> Maybe TypeclassInstance
    forall a. [a] -> Maybe a
    headMay ([TypeclassInstance] -> Maybe TypeclassInstance)
    -> [TypeclassInstance] -> Maybe TypeclassInstance
    forall a b. (a -> b) -> a -> b
    $ (TypeclassInstance -> Bool)
    -> [TypeclassInstance] -> [TypeclassInstance]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (TypeclassInstance -> Name -> Bool
    `instanceMatches` Name
    n) [TypeclassInstance]
    xs

    -- | Checks if the given name is the head of one of the paramaters of
    -- the given 'TypeclassInstance'.
    instanceMatches :: TypeclassInstance -> Name -> Bool
    instanceMatches :: TypeclassInstance -> Name -> Bool
    instanceMatches (TypeclassInstance [Type]
    _ Type
    typ [Dec]
    _) Name
    n' =
        -- We call unSigT to prevent outermost kind signatures from affecting the
        -- results. We also call unSigT a second time on the head of the
        -- application, as older versions of th-expand-syns incorrectly pushed
        -- kind signatures inwards when expanding type synonyms. (See #9.)
        case [Maybe Type] -> Maybe [Maybe Type]
    forall a. [a] -> Maybe [a]
    tailMay ([Maybe Type] -> Maybe [Maybe Type])
    -> [Maybe Type] -> Maybe [Maybe Type]
    forall a b. (a -> b) -> a -> b
    $ (Type -> Maybe Type) -> [Type] -> [Maybe Type]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Type -> Type) -> Maybe Type -> Maybe Type
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Type -> Type
    unSigT (Maybe Type -> Maybe Type)
    -> (Type -> Maybe Type) -> Type -> Maybe Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Type] -> Maybe Type
    forall a. [a] -> Maybe a
    headMay ([Type] -> Maybe Type) -> (Type -> [Type]) -> Type -> Maybe Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> [Type]
    unAppsT (Type -> [Type]) -> (Type -> Type) -> Type -> [Type]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Type
    unSigT) ([Type] -> [Maybe Type]) -> [Type] -> [Maybe Type]
    forall a b. (a -> b) -> a -> b
    $ Type -> [Type]
    unAppsT Type
    typ of
            Maybe [Maybe Type]
    Nothing -> Bool
    False
            Just [Maybe Type]
    xs -> Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ [()] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [() | Just (ConT Name
    n) <- [Maybe Type]
    xs, Name
    n Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    n']

    -- | Breaks a type application like @A b c@ into [A, b, c].
    unAppsT :: Type -> [Type]
    unAppsT :: Type -> [Type]
    unAppsT = [Type] -> Type -> [Type]
    go []
      where
        go :: [Type] -> Type -> [Type]
    go [Type]
    xs (AppT Type
    l Type
    x) = [Type] -> Type -> [Type]
    go (Type
    x Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    : [Type]
    xs) Type
    l
        go [Type]
    xs Type
    ty = Type
    ty Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    : [Type]
    xs

    -- | Remove any explicit kind signatures (i.e., 'SigT's) from a 'Type'.
    unSigT :: Type -> Type
    unSigT :: Type -> Type
    unSigT (SigT Type
    t Type
    _) = Type -> Type
    unSigT Type
    t
    unSigT Type
    t          = Type
    t