haskell - `lift` 一个类型到一个模板 Haskell `TypeQ`

Question

如果我有一个值(类型是 Lift typeclass 的实例)，我可以使用 lift创建评估为该值的术语的模板 Haskell 表示。
有没有类似的类型？举个小例子，假设我想写

foo :: (SomeAppropriateConstraintOn a) => proxy a -> ExpQ
foo pa = [| \x -> (x :: $(liftType pa)) |]

我将如何编写这个函数？
一个想法，在 this Reddit thread 中提到, 是使用 TypeRep的 a .然而，这并不像那个线程听起来那么简单。这是我尝试过的:一个函数可以变成 TypeRep a进入模板 Haskell Type通过递归地将其 tycon 名称包装在 ConT 中:

{-# LANGUAGE PolyKinds #-}

import Type.Reflection
import Language.Haskell.TH as TH

liftTypeRep :: TypeRep a -> TH.Type
liftTypeRep ty = foldl AppT t0 [liftTypeRep ty' | SomeTypeRep ty' <- args]
  where
    (con, args) = splitApps ty
    t0 = ConT $ mkName (tyConModule con <> "." <> tyConName con)

但这(不出所料)对于数据类型失败了。为了说明，让我们做一个简单的 Nat - 索引数据类型:

{-# LANGUAGE DataKinds, GADTs, KindSignatures #-}

import GHC.TypeLits

data Foo (n :: Nat) where
    MkFoo :: Foo n

现在，如果我尝试 liftTypeRep TypeRep的 Foo 42 ，我得到一个 absurd 的类型:

{-# LANGUAGE DataKinds, GADTs #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}

import Type.Reflection

test = $([| MkFoo :: $(pure $ liftTypeRep (typeRep :: TypeRep (Foo 42))) |])

错误信息是:

liftTypeRep.hs:8:10: error:
    • Illegal type constructor or class name: ‘42’
      When splicing a TH expression:
        Foo.MkFoo :: Foo.Foo (GHC.TypeLits.42)
    • In the untyped splice:
        $([| MkFoo ::
               $(pure $ liftTypeRep (typeRep :: TypeRep (Foo 42))) |])
  |
8 | test = $([| MkFoo :: $(pure $ liftTypeRep (typeRep :: TypeRep (Foo 42))) |])
  |          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

如果我们打印拼接，显然是错误的:

SigE (ConE Foo.MkFoo) (AppT (ConT Foo.Foo) (ConT GHC.TypeLits.42))

Answer 1

别人问这个，我最后写了 lift-type 来满足这个需求。
它最终有点麻烦，因为我们需要从类型字符串中解析出它是哪种类型。简单的情况适用于大多数类型 - 常规类型构造函数、函数，甚至提升的数据构造函数(例如 'True )。我在库中编写了一些测试，主要涵盖用例。
代码在这里:

liftType :: forall t. Typeable t => Type
liftType =
    go (typeRep @t)
  where
    go :: forall k (a :: k). TypeRep a -> Type
    go tr =
        case tr of
            Con tyCon ->
                mk tyCon
            App trA trB ->
                AppT (go trA) (go trB)
            Fun trA trB ->
                ConT ''(->) `AppT` go trA `AppT` go trB

    mk :: TyCon -> Type
    mk tyCon =
        let
            tcName =
                tyConName tyCon
        in
            if hasTick tcName
            then
                let
                    nameBase =
                        mkOccName (drop 1 tcName)
                    name =
                        Name nameBase flavor
                in
                    PromotedT name
            else if hasDigit tcName then
                LitT (NumTyLit (read tcName))
            else if hasQuote tcName then
                LitT (StrTyLit (stripQuotes tcName))
            else
                let
                    nameBase =
                        mkOccName tcName
                    flavor =
                        NameG
                            TcClsName
                            (mkPkgName $ tyConPackage tyCon)
                            (mkModName $ tyConModule tyCon)
                    name =
                        Name nameBase flavor
                in
                    ConT name

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

对于完整的导入和扩展，请参阅 Hackage 上的源代码。