{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
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
liftTypeQ :: forall t. Typeable t => Q Type
liftTypeQ :: forall {k} (t :: k). Typeable t => Q Type
liftTypeQ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Typeable t => Type
liftType @t
typeRepToType :: SomeTypeRep -> Type
typeRepToType :: SomeTypeRep -> Type
typeRepToType (SomeTypeRep TypeRep a
a) = 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 <- forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep (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` forall k (a :: k). TypeRep a -> Type
go TypeRep arg
trA Type -> Type -> Type
`AppT` forall k (a :: k). TypeRep a -> Type
go TypeRep res
trB
App TypeRep a
trA TypeRep b
trB ->
Type -> Type -> Type
AppT (forall k (a :: k). TypeRep a -> Type
go TypeRep a
trA) (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
trySymbol :: Maybe Type
trySymbol =
case String
tcName of
Char
'"' : String
cs ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TyLit -> Type
LitT (String -> TyLit
StrTyLit (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. a -> b -> a
const String
cs (forall a. Int -> [a] -> [a]
drop Int
1 String
cs)))
String
_ ->
forall a. Maybe a
Nothing
tryTicked :: Maybe Type
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 forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConPackage TyCon
tyCon)
(String -> ModName
mkModName forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConModule TyCon
tyCon)
name :: Name
name =
OccName -> NameFlavour -> Name
Name
OccName
nameBase
NameFlavour
flavor
in
forall a. a -> Maybe a
Just (Name -> Type
PromotedT Name
name)
String
_ ->
forall a. Maybe a
Nothing
tryNat :: Maybe Type
tryNat =
TyLit -> Type
LitT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> TyLit
NumTyLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => String -> Maybe a
readMaybe String
tcName
plainType :: Type
plainType =
let
nameBase :: OccName
nameBase =
String -> OccName
mkOccName String
tcName
flavor :: NameFlavour
flavor =
NameSpace -> PkgName -> ModName -> NameFlavour
NameG
NameSpace
TcClsName
(String -> PkgName
mkPkgName forall a b. (a -> b) -> a -> b
$ TyCon -> String
tyConPackage TyCon
tyCon)
(String -> ModName
mkModName 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
in forall a. a -> Maybe a -> a
fromMaybe Type
plainType forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [Maybe Type
tryTicked, Maybe Type
trySymbol, Maybe Type
tryNat]
liftType :: forall t. Typeable t => Type
liftType :: forall {k} (t :: k). Typeable t => Type
liftType =
SomeTypeRep -> Type
typeRepToType (forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (forall {k} (a :: k). Typeable a => TypeRep a
typeRep @t))