{-# 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