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

Question

如果我有一个值（类型是 Lift typeclass 的一个实例），我可以使用 lift 创建一个模板 Haskell 表示的术语到那个值。

有没有类似的类型？举个小例子，假设我想写

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

这个函数怎么写？

this Reddit thread 中提到的一个想法是使用 a 的 TypeRep。然而，这并不像该线程听起来那么简单。这是我尝试过的：通过递归地将其 tycon 名称包装在 ConT:

中，将 TypeRep a 转换为模板 Haskell Type 的函数

{-# 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 Foo 42 的 TypeRep，我得到一个无意义的类型：

{-# 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 上的源代码。

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

`lift` a type into a Template Haskell `TypeQ`

haskell

metaprogramming

template-haskell