[Git][ghc/ghc][wip/az/T22765-type-ann-missing] EPA: Add annotation for 'type' in DataDecl
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sun Jan 15 16:28:16 UTC 2023
Alan Zimmerman pushed to branch wip/az/T22765-type-ann-missing at Glasgow Haskell Compiler / GHC
Commits:
4e2bbe6c by Alan Zimmerman at 2023-01-15T16:28:03+00:00
EPA: Add annotation for 'type' in DataDecl
Closes #22765
- - - - -
6 changed files:
- compiler/GHC/Parser.y
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test22765.hs
- testsuite/tests/printer/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1279,7 +1279,7 @@ ty_decl :: { LTyClDecl GhcPs }
{% mkTyData (comb4 $1 $3 $4 $5) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
Nothing (reverse (snd $ unLoc $4))
(fmap reverse $5)
- ((fstOf3 $ unLoc $1):(fst $ unLoc $4)) }
+ ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
@@ -1290,7 +1290,7 @@ ty_decl :: { LTyClDecl GhcPs }
{% mkTyData (comb4 $1 $3 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
(snd $ unLoc $4) (snd $ unLoc $5)
(fmap reverse $6)
- ((fstOf3 $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
+ ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
@@ -1514,10 +1514,10 @@ at_decl_inst :: { LInstDecl GhcPs }
(fmap reverse $7)
((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) }
-type_data_or_newtype :: { Located (AddEpAnn, Bool, NewOrData) }
- : 'data' { sL1 $1 (mj AnnData $1,False,DataType) }
- | 'newtype' { sL1 $1 (mj AnnNewtype $1,False,NewType) }
- | 'type' 'data' { sL1 $1 (mj AnnData $1,True ,DataType) }
+type_data_or_newtype :: { Located ([AddEpAnn], Bool, NewOrData) }
+ : 'data' { sL1 $1 ([mj AnnData $1], False,DataType) }
+ | 'newtype' { sL1 $1 ([mj AnnNewtype $1], False,NewType) }
+ | 'type' 'data' { sL1 $1 ([mj AnnType $1, mj AnnData $2],True ,DataType) }
data_or_newtype :: { Located (AddEpAnn, NewOrData) }
: 'data' { sL1 $1 (mj AnnData $1,DataType) }
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -775,3 +775,9 @@ HsDocTy:
# See comment on pprWithDocString, this won't round trip
# $(CHECK_PPR) $(LIBDIR) HsDocTy.hs
$(CHECK_EXACT) $(LIBDIR) HsDocTy.hs
+
+.PHONY: Test22765
+Test22765:
+ $(CHECK_PPR) $(LIBDIR) Test22765.hs
+ $(CHECK_EXACT) $(LIBDIR) Test22765.hs
+
=====================================
testsuite/tests/printer/Test22765.hs
=====================================
@@ -0,0 +1,61 @@
+{-# LANGUAGE TypeData #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MonoLocalBinds #-}
+
+module Test22765 where
+
+import Data.Kind (Type)
+import Data.Type.Equality
+
+-- example from GHC User's Guide 6.4.10.6
+
+type data Ex :: Type where
+ MkEx :: forall a. a -> Ex
+
+type family UnEx (ex :: Ex) :: k
+type instance UnEx (MkEx x) = x
+
+-- -------------------------------------
+
+type data P = MkP
+data Prom = P
+
+-- -------------------------------------
+
+type data Nat = Zero | Succ Nat
+
+-- type level GADT
+type data Vec :: Nat -> Type -> Type where
+ VNil :: Vec Zero a
+ VCons :: a -> Vec n a -> Vec (Succ n) a
+
+type X = VCons Bool (VCons Int VNil)
+
+-- -------------------------------------
+
+type data Foo :: Type -> Type where
+ MkFoo1 :: a ~ Int => Foo a
+ MkFoo2 :: a ~~ Int => Foo a
+
+-- -------------------------------------
+
+-- splice should be equivalent to giving the declaration directly
+$( [d| type data Nat = Zero | Succ Nat |] )
+
+data Vec :: Nat -> Type -> Type where
+ VNil :: Vec Zero a
+ VCons :: a -> Vec n a -> Vec (Succ n) a
+
+instance Functor (Vec n) where
+ fmap _ VNil = VNil
+ fmap f (VCons x xs) = VCons (f x) (fmap f xs)
+
+-- -------------------------------------
+
+type data List a = Nil | Cons a (List a)
+
+type data Pair a b = MkPair a b
+
+type data Sum a b = L a | R b
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -186,4 +186,5 @@ test('T22488', normal, ghci_script, ['T22488.script'])
test('T22488_docHead', normal, compile_and_run, ['-package ghc'])
test('T20531', extra_files(['T20531_defs.hs']), ghci_script, ['T20531.script'])
test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_red_ticks.script'])
-test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
\ No newline at end of file
+test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
+test('Test22765', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22765'])
\ No newline at end of file
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3643,9 +3643,13 @@ exactDataDefn an exactHdr
an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]
- an0 <- markEpAnnL an' lidl $ case condecls of
- DataTypeCons _ _ -> AnnData
- NewTypeCon _ -> AnnNewtype
+ an0 <- case condecls of
+ DataTypeCons is_type_data _ -> do
+ an0' <- if is_type_data
+ then markEpAnnL an' lidl AnnType
+ else return an'
+ markEpAnnL an' lidl AnnData
+ NewTypeCon _ -> markEpAnnL an' lidl AnnNewtype
an1 <- markEpAnnL an0 lidl AnnInstance -- optional
mb_ct' <- mapM markAnnotated mb_ct
=====================================
utils/check-exact/Main.hs
=====================================
@@ -203,7 +203,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
-- "../../testsuite/tests/printer/PprArrowLambdaCase.hs" Nothing
-- "../../testsuite/tests/printer/Test16279.hs" Nothing
- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
+ -- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
+ "../../testsuite/tests/printer/Test22765.hs" Nothing
-- cloneT does not need a test, function can be retired
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e2bbe6c5cfd6712ffac693e55484a6e8b7cfcce
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e2bbe6c5cfd6712ffac693e55484a6e8b7cfcce
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230115/c283908f/attachment-0001.html>
More information about the ghc-commits
mailing list