    {-# LANGUAGE AllowAmbiguousTypes #-}
    {-# LANGUAGE GADTs #-}
    {-# LANGUAGE PolyKinds #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeApplications #-}
    {-# LANGUAGE TypeInType #-}
    {-# LANGUAGE TypeOperators #-}

    -- | Template Haskell has a class 'Lift' that allows you to promote values
    -- from Haskell-land into the land of metaprogramming - 'Q'.
    --
    -- @
    -- class 'Lift' a where
    --     'lift' :: a -> 'Q' 'Exp'
    --
    --     'liftTyped' :: a -> 'Q' ('TExp' a)
    -- @
    --
    -- However, there wasn't a way to promote a *type* into a @'Q' 'Type'@.
    --
    -- This library provides exactly that function. It requires a 'Typeable'
    -- constraint, but this is automatically satisfied by GHC.
    --
    -- @since 0.1.0.0
    module LiftType where

    import Data.Foldable (asum)
    import qualified Data.Kind as Kind
    import Data.Maybe (fromMaybe)
    import Language.Haskell.TH.Syntax
    import Text.Read (readMaybe)
    import Type.Reflection

    -- | Convert a type argument into a Template Haskell 'Type'.
    --
    -- Use with @TypeApplications@.
    --
    -- Example:
    --
    -- @
    -- >>> :set -XTypeApplications
    -- >>> liftType \@Bool
    -- ConT GHC.Types.Bool
    -- >>> liftType \@[Char]
    -- AppT (ConT GHC.Types.[]) (ConT GHC.Types.Char)
    -- @
    --
    -- This works with data kinds, too.
    --
    -- @
    -- >>> :set -XDataKinds
    -- >>> liftType \@3
    -- LitT (NumTyLit 3)
    -- >>> liftType \@"hello"
    -- LitT (StrTyLit "hello")
    -- >>> liftType \@'[Int, Char]
    -- AppT (AppT (PromotedT GHC.Types.:) (ConT GHC.Types.Int)) (AppT (AppT (PromotedT GHC.Types.:) (ConT GHC.Types.Char)) (PromotedT GHC.Types.[]))
    -- >>> liftType \@'(Int, Char)
    -- AppT (AppT (PromotedT GHC.Tuple.(,)) (ConT GHC.Types.Int)) (ConT GHC.Types.Char)
    -- @
    --
    -- @since 0.1.0.0
    liftType :: forall t. Typeable t => Type
    liftType :: forall {k} (t :: k). Typeable t => Type
    liftType =
        SomeTypeRep -> Type
    typeRepToType (TypeRep t -> SomeTypeRep
    forall k (a :: k). TypeRep a -> SomeTypeRep
    SomeTypeRep (forall (a :: k). Typeable a => TypeRep a
    forall {k} (a :: k). Typeable a => TypeRep a
    typeRep @t))

    -- | 'liftType' promoted to the 'Q' monad.
    --
    -- @since 0.1.0.0
    liftTypeQ :: forall t. Typeable t => Q Type
    liftTypeQ :: forall {k} (t :: k). Typeable t => Q Type
    liftTypeQ = Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Type -> Q Type) -> Type -> Q Type
    forall a b. (a -> b) -> a -> b
    $ forall (t :: k). Typeable t => Type
    forall {k} (t :: k). Typeable t => Type
    liftType @t

    -- | Promote a 'SomeTypeRep' into a 'Type'.
    --
    -- @since 0.1.1.0
    typeRepToType :: SomeTypeRep -> Type
    typeRepToType :: SomeTypeRep -> Type
    typeRepToType (SomeTypeRep TypeRep a
    a) = TypeRep a -> Type
    forall k (a :: k). TypeRep a -> Type
    go TypeRep a
    a
      where
        go :: forall k (a :: k). TypeRep a -> Type
        go :: forall k (a :: k). TypeRep a -> Type
    go TypeRep a
    tr
            | Just * :~~: a
    HRefl <- TypeRep (*) -> TypeRep a -> Maybe (* :~~: a)
    forall k1 k2 (a :: k1) (b :: k2).
    TypeRep a -> TypeRep b -> Maybe (a :~~: b)
    eqTypeRep (forall a. Typeable a => TypeRep a
    forall {k} (a :: k). Typeable a => TypeRep a
    typeRep @Kind.Type) TypeRep a
    tr
            = Name -> Type
    ConT ''Kind.Type
            | Bool
    otherwise =
            case TypeRep a
    tr of
                Con TyCon
    tyCon ->
                    TyCon -> Type
    mk TyCon
    tyCon
                Fun TypeRep arg
    trA TypeRep res
    trB ->
                    Name -> Type
    ConT ''(->) Type -> Type -> Type
    `AppT` TypeRep arg -> Type
    forall k (a :: k). TypeRep a -> Type
    go TypeRep arg
    trA Type -> Type -> Type
    `AppT` TypeRep res -> Type
    forall k (a :: k). TypeRep a -> Type
    go TypeRep res
    trB
                App TypeRep a
    trA TypeRep b
    trB ->
                    Type -> Type -> Type
    AppT (TypeRep a -> Type
    forall k (a :: k). TypeRep a -> Type
    go TypeRep a
    trA) (TypeRep b -> Type
    forall k (a :: k). TypeRep a -> Type
    go TypeRep b
    trB)

        mk :: TyCon -> Type
        mk :: TyCon -> Type
    mk TyCon
    tyCon =
            let
                tcName :: String
    tcName =
                    TyCon -> String
    tyConName TyCon
    tyCon
                typeOrDataName :: TypeOrDataName
    typeOrDataName =
                    TyCon -> TypeOrDataName
    tyConToName TyCon
    tyCon
                trySymbol :: Maybe Type
    trySymbol =
                    case String
    tcName of
                        Char
    '"' : String
    cs ->
                            Type -> Maybe Type
    forall a. a -> Maybe a
    Just (Type -> Maybe Type) -> Type -> Maybe Type
    forall a b. (a -> b) -> a -> b
    $ TyLit -> Type
    LitT (String -> TyLit
    StrTyLit ((Char -> Char -> Char) -> String -> String -> String
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Char -> Char -> Char
    forall a b. a -> b -> a
    const String
    cs (Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop Int
    1 String
    cs)))
                        String
    _ ->
                            Maybe Type
    forall a. Maybe a
    Nothing
                tryTicked :: Maybe Type
    tryTicked =
                    case TypeOrDataName
    typeOrDataName of
                        PromotedDataName Name
    name ->
                            Type -> Maybe Type
    forall a. a -> Maybe a
    Just (Name -> Type
    PromotedT Name
    name)
                        TypeOrDataName
    _ ->
                            Maybe Type
    forall a. Maybe a
    Nothing
                tryNat :: Maybe Type
    tryNat =
                    TyLit -> Type
    LitT (TyLit -> Type) -> (Integer -> TyLit) -> Integer -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Integer -> TyLit
    NumTyLit (Integer -> Type) -> Maybe Integer -> Maybe Type
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Maybe Integer
    forall a. Read a => String -> Maybe a
    readMaybe String
    tcName
                plainType :: Type
    plainType =
                    Name -> Type
    ConT (TypeOrDataName -> Name
    getTypeOrDataName TypeOrDataName
    typeOrDataName)
            in Type -> Maybe Type -> Type
    forall a. a -> Maybe a -> a
    fromMaybe Type
    plainType (Maybe Type -> Type) -> Maybe Type -> Type
    forall a b. (a -> b) -> a -> b
    $ [Maybe Type] -> Maybe Type
    forall (t :: * -> *) (f :: * -> *) a.
    (Foldable t, Alternative f) =>
    t (f a) -> f a
    asum [Maybe Type
    tryTicked, Maybe Type
    trySymbol, Maybe Type
    tryNat]

    -- | Extract the 'TypeOrDataName' from a 'TyCon'. You probably want to use
    -- 'typeToName' instead. See that function for documentation and more
    -- information.
    --
    -- @since 0.1.2.0
    tyConToName :: TyCon -> TypeOrDataName
    tyConToName :: TyCon -> TypeOrDataName
    tyConToName TyCon
    tyCon =
        let
            tcName :: String
    tcName =
                TyCon -> String
    tyConName TyCon
    tyCon
            tryTicked :: Maybe TypeOrDataName
    tryTicked =
                case String
    tcName of
                    Char
    '\'' : String
    dcName ->
                        let nameBase :: OccName
    nameBase =
                                String -> OccName
    mkOccName String
    dcName

                            flavor :: NameFlavour
    flavor =
                                NameSpace -> PkgName -> ModName -> NameFlavour
    NameG
                                    NameSpace
    DataName
                                    (String -> PkgName
    mkPkgName (String -> PkgName) -> String -> PkgName
    forall a b. (a -> b) -> a -> b
    $ TyCon -> String
    tyConPackage TyCon
    tyCon)
                                    (String -> ModName
    mkModName (String -> ModName) -> String -> ModName
    forall a b. (a -> b) -> a -> b
    $ TyCon -> String
    tyConModule TyCon
    tyCon)
                            name :: Name
    name =
                                OccName -> NameFlavour -> Name
    Name
                                    OccName
    nameBase
                                    NameFlavour
    flavor
                        in
                            TypeOrDataName -> Maybe TypeOrDataName
    forall a. a -> Maybe a
    Just (Name -> TypeOrDataName
    PromotedDataName Name
    name)
                    String
    _ ->
                        Maybe TypeOrDataName
    forall a. Maybe a
    Nothing
            plainType :: TypeOrDataName
    plainType =
                let
                    nameBase :: OccName
    nameBase =
                        String -> OccName
    mkOccName String
    tcName
                    flavor :: NameFlavour
    flavor =
                        NameSpace -> PkgName -> ModName -> NameFlavour
    NameG
                            NameSpace
    TcClsName
                            (String -> PkgName
    mkPkgName (String -> PkgName) -> String -> PkgName
    forall a b. (a -> b) -> a -> b
    $ TyCon -> String
    tyConPackage TyCon
    tyCon)
                            (String -> ModName
    mkModName (String -> ModName) -> String -> ModName
    forall a b. (a -> b) -> a -> b
    $ TyCon -> String
    tyConModule TyCon
    tyCon)
                    name :: Name
    name =
                        OccName -> NameFlavour -> Name
    Name
                            OccName
    nameBase
                            NameFlavour
    flavor
                in
                    Name -> TypeOrDataName
    TypeName Name
    name
        in TypeOrDataName -> Maybe TypeOrDataName -> TypeOrDataName
    forall a. a -> Maybe a -> a
    fromMaybe TypeOrDataName
    plainType Maybe TypeOrDataName
    tryTicked

    -- | This function returns the name of the outermost type constructor.
    --
    -- >>> typeToName @Char
    -- TypeName ''Char
    -- >>> typeToName @Maybe
    -- TypeName ''Maybe
    -- >>> typeToName @(Maybe Char)
    -- TypeName ''Maybe
    -- >>> typeToName @(Int -> Char)
    -- TypeName ''(->)
    -- >>> typeToName @'False
    -- PromotedDataName 'False
    --
    -- @since 0.1.2.0
    typeToName :: forall t. Typeable t => TypeOrDataName
    typeToName :: forall {k} (t :: k). Typeable t => TypeOrDataName
    typeToName = TyCon -> TypeOrDataName
    tyConToName (TypeRep t -> TyCon
    forall {k} (a :: k). TypeRep a -> TyCon
    typeRepTyCon (forall (a :: k). Typeable a => TypeRep a
    forall {k} (a :: k). Typeable a => TypeRep a
    typeRep @t))

    -- | It's possible to use a data constructor with a @DataKinds@ promotion.
    -- This disambiguates where the name comes from.
    --
    -- @since 0.1.2.0
    data TypeOrDataName
        = TypeName Name
        | PromotedDataName Name
        deriving (Int -> TypeOrDataName -> String -> String
    [TypeOrDataName] -> String -> String
    TypeOrDataName -> String
    (Int -> TypeOrDataName -> String -> String)
    -> (TypeOrDataName -> String)
    -> ([TypeOrDataName] -> String -> String)
    -> Show TypeOrDataName
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> TypeOrDataName -> String -> String
    showsPrec :: Int -> TypeOrDataName -> String -> String
    $cshow :: TypeOrDataName -> String
    show :: TypeOrDataName -> String
    $cshowList :: [TypeOrDataName] -> String -> String
    showList :: [TypeOrDataName] -> String -> String
    Show, TypeOrDataName -> TypeOrDataName -> Bool
    (TypeOrDataName -> TypeOrDataName -> Bool)
    -> (TypeOrDataName -> TypeOrDataName -> Bool) -> Eq TypeOrDataName
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: TypeOrDataName -> TypeOrDataName -> Bool
    == :: TypeOrDataName -> TypeOrDataName -> Bool
    $c/= :: TypeOrDataName -> TypeOrDataName -> Bool
    /= :: TypeOrDataName -> TypeOrDataName -> Bool
    Eq)

    -- | Retrieve the 'Name' from a 'TypeOrDataName', forgetting how it was
    -- parsed.
    --
    -- @since 0.1.2.0
    getTypeOrDataName :: TypeOrDataName -> Name
    getTypeOrDataName :: TypeOrDataName -> Name
    getTypeOrDataName TypeOrDataName
    d =
        case TypeOrDataName
    d of
            TypeName Name
    n ->
                Name
    n
            PromotedDataName Name
    n ->
                Name
    n