{-# language TypeInType, ScopedTypeVariables, AllowAmbiguousTypes, TypeApplications, PolyKinds, TemplateHaskell #-}

-- | 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.Char
import Control.Applicative
import Type.Reflection
import Language.Haskell.TH.Syntax

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

-- | 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 :: Type
liftType =
    TypeRep t -> Type
forall k (a :: k). TypeRep a -> Type
go (Typeable t => TypeRep t
forall k (a :: k). Typeable a => TypeRep a
typeRep @t)
  where
    go :: forall k (a :: k). TypeRep a -> Type
    go :: TypeRep a -> Type
go TypeRep a
tr =
        case TypeRep a
tr of
            Con TyCon
tyCon ->
                TyCon -> Type
mk TyCon
tyCon
            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)
            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

    mk :: TyCon -> Type
    mk :: TyCon -> Type
mk TyCon
tyCon =
        let
            tcName :: String
tcName =
                TyCon -> String
tyConName TyCon
tyCon
        in
            if String -> Bool
hasTick String
tcName
            then
                let
                    nameBase :: OccName
nameBase =
                        String -> OccName
mkOccName (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
tcName)
                    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
                    Name -> Type
PromotedT Name
name
            else if String -> Bool
hasDigit String
tcName then
                TyLit -> Type
LitT (Integer -> TyLit
NumTyLit (String -> Integer
forall a. Read a => String -> a
read String
tcName))
            else if String -> Bool
hasQuote String
tcName then
                TyLit -> Type
LitT (String -> TyLit
StrTyLit (String -> String
stripQuotes String
tcName))
            else
                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 -> Type
ConT Name
name

    stripQuotes :: String -> String
stripQuotes String
xs =
        case String
xs of
            [] ->
                []
            (Char
'"' : String
rest) ->
                String -> String
forall a. [a] -> [a]
reverse (String -> String
stripQuotes (String -> String
forall a. [a] -> [a]
reverse String
rest))
            String
_ ->
                String
xs
    hasTick :: String -> Bool
hasTick = (Char -> Bool) -> String -> Bool
prefixSatisfying (Char
'\'' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)
    hasDigit :: String -> Bool
hasDigit = (Char -> Bool) -> String -> Bool
prefixSatisfying Char -> Bool
isDigit
    hasQuote :: String -> Bool
hasQuote = (Char -> Bool) -> String -> Bool
prefixSatisfying (Char
'"' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)
    isList :: String -> Bool
isList = (String
"'[]" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==)
    prefixSatisfying :: (Char -> Bool) -> [Char] -> Bool
    prefixSatisfying :: (Char -> Bool) -> String -> Bool
prefixSatisfying Char -> Bool
p String
xs =
        case String
xs of
            Char
a : String
_ ->
                Char -> Bool
p Char
a
            String
_ ->
                Bool
False