Commit 9a3ca8de authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Support signatures at the kind level in Template Haskell

`repNonArrowKind` was missing a case for `HsKindSig`, which this
commit adds. Fixes #13781.

Test Plan: make test TEST=T13781

Reviewers: goldfire, austin, bgamari

Reviewed By: goldfire

Subscribers: rwbarton, thomie

GHC Trac Issues: #13781

Differential Revision: https://phabricator.haskell.org/D3627
parent 6ddb3aaf
......@@ -1069,6 +1069,12 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
-- represent a kind
--
-- It would be great to scrap this function in favor of repLTy, since Types
-- and Kinds are the same things. We have not done so yet for engineering
-- reasons, as repLTy returns a monadic TypeQ, whereas repLKind returns a pure
-- Kind, so in order to replace repLKind with repLTy, we'd need to go through
-- and purify repLTy and every monadic function it calls. This is the subject
-- GHC Trac #11785.
repLKind :: LHsKind GhcRn -> DsM (Core TH.Kind)
repLKind ki
= do { let (kis, ki') = splitHsFunType ki
......@@ -1109,6 +1115,10 @@ repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks
; kcon <- repKTuple (length ks)
; repKApps kcon ks'
}
repNonArrowKind (HsKindSig k sort) = do { k' <- repLKind k
; sort' <- repLKind sort
; repKSig k' sort'
}
repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
......@@ -2351,6 +2361,9 @@ repKStar = rep2 starKName []
repKConstraint :: DsM (Core TH.Kind)
repKConstraint = rep2 constraintKName []
repKSig :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
repKSig (MkC k) (MkC sort) = rep2 sigTDataConName [k, sort]
----------------------------------------------------------
-- Type family result signature
......
......@@ -94,7 +94,7 @@ templateHaskellNames = [
-- Type
forallTName, varTName, conTName, appTName, equalityTName,
tupleTName, unboxedTupleTName, unboxedSumTName,
arrowTName, listTName, sigTName, litTName,
arrowTName, listTName, sigTName, sigTDataConName, litTName,
promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
wildCardTName,
-- TyLit
......@@ -428,9 +428,10 @@ recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
-- data Type = ...
forallTName, varTName, conTName, tupleTName, unboxedTupleTName,
unboxedSumTName, arrowTName, listTName, appTName, sigTName, equalityTName,
litTName, promotedTName, promotedTupleTName, promotedNilTName,
promotedConsTName, wildCardTName :: Name
unboxedSumTName, arrowTName, listTName, appTName, sigTName,
sigTDataConName, equalityTName, litTName, promotedTName,
promotedTupleTName, promotedNilTName, promotedConsTName,
wildCardTName :: Name
forallTName = libFun (fsLit "forallT") forallTIdKey
varTName = libFun (fsLit "varT") varTIdKey
conTName = libFun (fsLit "conT") conTIdKey
......@@ -441,6 +442,9 @@ arrowTName = libFun (fsLit "arrowT") arrowTIdKey
listTName = libFun (fsLit "listT") listTIdKey
appTName = libFun (fsLit "appT") appTIdKey
sigTName = libFun (fsLit "sigT") sigTIdKey
-- Yes, we need names for both the monadic sigT as well as the pure SigT. Why?
-- Refer to the documentation for repLKind in DsMeta.
sigTDataConName = thCon (fsLit "SigT") sigTDataConKey
equalityTName = libFun (fsLit "equalityT") equalityTIdKey
litTName = libFun (fsLit "litT") litTIdKey
promotedTName = libFun (fsLit "promotedT") promotedTIdKey
......@@ -947,8 +951,9 @@ recordPatSynIdKey = mkPreludeMiscIdUnique 372
-- data Type = ...
forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,
equalityTIdKey, litTIdKey, promotedTIdKey, promotedTupleTIdKey,
promotedNilTIdKey, promotedConsTIdKey, wildCardTIdKey :: Unique
sigTDataConKey, equalityTIdKey, litTIdKey, promotedTIdKey,
promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
wildCardTIdKey :: Unique
forallTIdKey = mkPreludeMiscIdUnique 381
varTIdKey = mkPreludeMiscIdUnique 382
conTIdKey = mkPreludeMiscIdUnique 383
......@@ -959,13 +964,14 @@ arrowTIdKey = mkPreludeMiscIdUnique 387
listTIdKey = mkPreludeMiscIdUnique 388
appTIdKey = mkPreludeMiscIdUnique 389
sigTIdKey = mkPreludeMiscIdUnique 390
equalityTIdKey = mkPreludeMiscIdUnique 391
litTIdKey = mkPreludeMiscIdUnique 392
promotedTIdKey = mkPreludeMiscIdUnique 393
promotedTupleTIdKey = mkPreludeMiscIdUnique 394
promotedNilTIdKey = mkPreludeMiscIdUnique 395
promotedConsTIdKey = mkPreludeMiscIdUnique 396
wildCardTIdKey = mkPreludeMiscIdUnique 397
sigTDataConKey = mkPreludeMiscIdUnique 391
equalityTIdKey = mkPreludeMiscIdUnique 392
litTIdKey = mkPreludeMiscIdUnique 393
promotedTIdKey = mkPreludeMiscIdUnique 394
promotedTupleTIdKey = mkPreludeMiscIdUnique 395
promotedNilTIdKey = mkPreludeMiscIdUnique 396
promotedConsTIdKey = mkPreludeMiscIdUnique 397
wildCardTIdKey = mkPreludeMiscIdUnique 398
-- data TyLit = ...
numTyLitIdKey, strTyLitIdKey :: Unique
......
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeInType #-}
module T13781 where
import Data.Kind
import Data.Proxy
$([d| f :: Proxy (a :: (k :: Type))
f = Proxy
|])
......@@ -386,3 +386,4 @@ test('T13473', normal, multimod_compile_and_run,
test('T13587', expect_broken(13587), compile_and_run, ['-v0'])
test('T13618', normal, compile_and_run, ['-v0'])
test('T13642', normal, compile_fail, ['-v0'])
test('T13781', normal, compile, ['-v0'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment