{-# 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 :: Proxy a -> Q Type
liftTypeFromTypeable Proxy a
p = TypeRep -> Q Type
go do Proxy a -> TypeRep
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 (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
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 ]

-- |
--
-- TODO: correct reifying
-- NOTICE: introduce @reifyType@ by GHC 8.10
--
tyConToType :: Typeable.TyCon -> TH.Q TH.Type
tyConToType :: TyCon -> Q Type
tyConToType TyCon
tyCon = do
    Maybe Name
mn <- String -> Q (Maybe Name)
TH.lookupTypeName String
tyConQualifiedName
    case Maybe Name
mn of
        Just Name
n  -> Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Type
TH.ConT Name
n
        Maybe Name
Nothing -> case String
tyConQualifiedName of
            String
"GHC.Tuple.()" ->
                Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Int -> Type
TH.TupleT Int
0
            String
_  ->
                String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail do String
"Missing type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tyConQualifiedName
    where
        tyConQualifiedName :: String
tyConQualifiedName = TyCon -> String
Typeable.tyConModule TyCon
tyCon String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ TyCon -> String
Typeable.tyConName TyCon
tyCon