CODEWITHSUNDEEP
haskellmetaprogrammingtemplate-haskell
Cactus
Cactus

Reputation: 27626

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

If I have a value (of a type that is an instance of the Lift typeclass), I can use lift to create a Template Haskell representation of a term that evaluates to that value.

Is there anything similar for types? To give a small example, suppose I wanted to write

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

How would I write this function?

One idea, alluded to in this Reddit thread, is to use the TypeRep of a. However, this isn't as simple as that thread makes it sound. Here's what I tried: a function that turns TypeRep a into a Template Haskell Type by recursively wrapping its tycon names in 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)

But this (unsurprisingly) fails for data kinds. To illustrate, let's make a simple Nat-indexed data type:

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

import GHC.TypeLits

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

Now if I try to liftTypeRep the TypeRep of Foo 42, I get a nonsensical type:

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

import Type.Reflection

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

The error message is:

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))) |])
  |          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

If we print the splice, it is obviously wrong:

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

Upvotes: 4

Views: 195

Answers (1)

ephrion
ephrion

Reputation: 2697

Someone else asked this, and I ended up writing lift-type to fill this need.

It ends up being a bit hairy, since we need to parse out what sort of type it is from the type string. The easy case works for most types - regular type constructors, functions, even promoted data constructors (eg 'True). I wrote some tests in the library that mostly cover the use case.

The code is here:

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

FOr full imports and extensions, see the source on Hackage.

Upvotes: 2

Related Questions