{-# language TypeInType, ScopedTypeVariables, AllowAmbiguousTypes, TypeApplications, PolyKinds, TemplateHaskell #-}
module LiftType where
import Data.Char
import Control.Applicative
import Type.Reflection
import Language.Haskell.TH.Syntax
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
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