{-# LANGUAGE TemplateHaskell #-}

module Language.Lexer.Tlex.Data.TypeableTH (
    liftTypeFromTypeable,
    tyConToType,
) where

import           Prelude

import           Data.Foldable       (foldl')
import qualified Data.Typeable       as Typeable
import qualified Language.Haskell.TH as TH

liftTypeFromTypeable :: Typeable.Typeable a => Typeable.Proxy a -> TH.Q TH.Type
liftTypeFromTypeable :: forall {k} (a :: k). Typeable a => Proxy a -> Q Type
liftTypeFromTypeable Proxy a
p = TypeRep -> Q Type
go do forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep Proxy a
p where
    go :: TypeRep -> Q Type
go TypeRep
r0 =
        let (TyCon
tyCon, [TypeRep]
rs) = TypeRep -> (TyCon, [TypeRep])
Typeable.splitTyConApp TypeRep
r0
        in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
            do \Q Type
tq1 Q Type
tq2 -> [t|$(tq1) $(tq2)|]
            do TyCon -> Q Type
tyConToType TyCon
tyCon
            do [ TypeRep -> Q Type
go TypeRep
r | TypeRep
r <- [TypeRep]
rs ]

tyConToType :: Typeable.TyCon -> TH.Q TH.Type
tyConToType :: TyCon -> Q Type
tyConToType TyCon
tyCon = String -> Q (Maybe Name)
TH.lookupTypeName String
tyConQualifiedName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Name
n  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Type
TH.ConT Name
n
    Maybe Name
Nothing -> String -> Q (Maybe Name)
TH.lookupTypeName String
tyConName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Name
n  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Type
TH.ConT Name
n
        Maybe Name
Nothing -> case String
tyConName of
            String
"()" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure do Int -> Type
TH.TupleT Int
0
            String
_    -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail do String
"Missing type: " forall a. [a] -> [a] -> [a]
++ String
tyConQualifiedName
    where
        tyConName :: String
tyConName = TyCon -> String
Typeable.tyConName TyCon
tyCon
        tyConQualifiedName :: String
tyConQualifiedName = TyCon -> String
Typeable.tyConModule TyCon
tyCon forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
tyConName