1{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} 2 3#if __GLASGOW_HASKELL__ >= 704 4{-# LANGUAGE ConstraintKinds #-} 5#endif 6 7#if __GLASGOW_HASKELL__ >= 807 8{-# LANGUAGE DataKinds #-} 9{-# LANGUAGE TypeApplications #-} 10#endif 11 12#if MIN_VERSION_template_haskell(2,8,0) 13{-# Language PolyKinds #-} 14#endif 15 16{-| 17Module : Main 18Description : Test cases for the th-abstraction package 19Copyright : Eric Mertens 2017 20License : ISC 21Maintainer : emertens@gmail.com 22 23This module checks that the 'reifyDatatype' logic works consistently 24across a wide range of datatypes. These tests are validated across 25the versions of GHC supported by this package. 26 27-} 28module Main (main) where 29 30#if __GLASGOW_HASKELL__ >= 704 31import Control.Monad (zipWithM_) 32#endif 33 34import Control.Monad (unless) 35import qualified Data.Map as Map 36 37#if MIN_VERSION_base(4,7,0) 38import Data.Type.Equality ((:~:)(..)) 39#endif 40 41import Language.Haskell.TH 42import Language.Haskell.TH.Datatype 43import Language.Haskell.TH.Datatype.TyVarBndr 44import Language.Haskell.TH.Lib (starK) 45 46import Harness 47import Types 48 49-- | Test entry point. Tests will pass or fail at compile time. 50main :: IO () 51main = 52 do adt1Test 53 gadt1Test 54 gadt2Test 55 gadtrec1Test 56 equalTest 57 showableTest 58 recordTest 59 voidstosTest 60 strictDemoTest 61 recordVanillaTest 62#if MIN_VERSION_template_haskell(2,6,0) 63 t43Test 64 t58Test 65#endif 66#if MIN_VERSION_template_haskell(2,7,0) 67 dataFamilyTest 68 ghc78bugTest 69 quotedTest 70 polyTest 71 gadtFamTest 72 famLocalDecTest1 73 famLocalDecTest2 74 recordFamTest 75 t46Test 76 t73Test 77#endif 78 fixityLookupTest 79#if __GLASGOW_HASKELL__ >= 704 80 resolvePredSynonymsTest 81#endif 82 reifyDatatypeWithConNameTest 83 reifyConstructorTest 84#if MIN_VERSION_base(4,7,0) 85 importedEqualityTest 86#endif 87#if MIN_VERSION_template_haskell(2,8,0) 88 kindSubstTest 89 t59Test 90 t61Test 91 t66Test 92 t80Test 93#endif 94#if MIN_VERSION_template_haskell(2,11,0) 95 t79Test 96#endif 97#if __GLASGOW_HASKELL__ >= 800 98 t37Test 99 polyKindedExTyvarTest 100#endif 101#if __GLASGOW_HASKELL__ >= 807 102 resolveTypeSynonymsVKATest 103#endif 104 regressionTest44 105 t63Test 106 t70Test 107 108adt1Test :: IO () 109adt1Test = 110 $(do info <- reifyDatatype ''Adt1 111 112 let names = map mkName ["a","b"] 113 [aTvb,bTvb] = map (\v -> kindedTV v starK) names 114 vars@[aVar,bVar] = map (VarT . mkName) ["a","b"] 115 [aSig,bSig] = map (\v -> SigT v starK) vars 116 117 validateDI info 118 DatatypeInfo 119 { datatypeName = ''Adt1 120 , datatypeContext = [] 121 , datatypeVars = [aTvb,bTvb] 122 , datatypeInstTypes = [aSig, bSig] 123 , datatypeVariant = Datatype 124 , datatypeCons = 125 [ ConstructorInfo 126 { constructorName = 'Adtc1 127 , constructorContext = [] 128 , constructorVars = [] 129 , constructorFields = [AppT (AppT (TupleT 2) aVar) bVar] 130 , constructorStrictness = [notStrictAnnot] 131 , constructorVariant = NormalConstructor } 132 , ConstructorInfo 133 { constructorName = 'Adtc2 134 , constructorContext = [] 135 , constructorVars = [] 136 , constructorFields = [ConT ''Bool, ConT ''Int] 137 , constructorStrictness = [notStrictAnnot, notStrictAnnot] 138 , constructorVariant = InfixConstructor } 139 ] 140 } 141 ) 142 143gadt1Test :: IO () 144gadt1Test = 145 $(do info <- reifyDatatype ''Gadt1 146 147 let a = mkName "a" 148 aVar = VarT a 149 150 validateDI info 151 DatatypeInfo 152 { datatypeName = ''Gadt1 153 , datatypeContext = [] 154 , datatypeVars = [kindedTV a starK] 155 , datatypeInstTypes = [SigT aVar starK] 156 , datatypeVariant = Datatype 157 , datatypeCons = 158 [ ConstructorInfo 159 { constructorName = 'Gadtc1 160 , constructorVars = [] 161 , constructorContext = [equalPred aVar (ConT ''Int)] 162 , constructorFields = [ConT ''Int] 163 , constructorStrictness = [notStrictAnnot] 164 , constructorVariant = NormalConstructor } 165 , ConstructorInfo 166 { constructorName = 'Gadtc2 167 , constructorVars = [] 168 , constructorContext = [] 169 , constructorFields = [AppT (AppT (TupleT 2) aVar) aVar] 170 , constructorStrictness = [notStrictAnnot] 171 , constructorVariant = NormalConstructor } 172 , ConstructorInfo 173 { constructorName = '(:**:) 174 , constructorVars = [] 175 , constructorContext = [equalPred aVar (TupleT 0)] 176 , constructorFields = [ConT ''Bool, ConT ''Char] 177 , constructorStrictness = [notStrictAnnot, notStrictAnnot] 178 , constructorVariant = InfixConstructor } 179 , ConstructorInfo 180 { constructorName = '(:!!:) 181 , constructorVars = [] 182 , constructorContext = [equalPred aVar (ConT ''Double)] 183 , constructorFields = [ConT ''Char, ConT ''Bool] 184 , constructorStrictness = [notStrictAnnot, notStrictAnnot] 185 , constructorVariant = NormalConstructor } 186 ] 187 } 188 ) 189 190gadtrec1Test :: IO () 191gadtrec1Test = 192 $(do info <- reifyDatatype ''Gadtrec1 193 194 let a = mkName "a" 195 con = gadtRecVanillaCI 196 197 validateDI info 198 DatatypeInfo 199 { datatypeName = ''Gadtrec1 200 , datatypeContext = [] 201 , datatypeVars = [kindedTV a starK] 202 , datatypeInstTypes = [SigT (VarT a) starK] 203 , datatypeVariant = Datatype 204 , datatypeCons = 205 [ con, con { constructorName = 'Gadtrecc2 } ] 206 } 207 ) 208 209equalTest :: IO () 210equalTest = 211 $(do info <- reifyDatatype ''Equal 212 213 let names = map mkName ["a","b","c"] 214 [aTvb,bTvb,cTvb] = map (\v -> kindedTV v starK) names 215 vars@[aVar,bVar,cVar] = map VarT names 216 [aSig,bSig,cSig] = map (\v -> SigT v starK) vars 217 218 validateDI info 219 DatatypeInfo 220 { datatypeName = ''Equal 221 , datatypeContext = [] 222 , datatypeVars = [aTvb, bTvb, cTvb] 223 , datatypeInstTypes = [aSig, bSig, cSig] 224 , datatypeVariant = Datatype 225 , datatypeCons = 226 [ ConstructorInfo 227 { constructorName = 'Equalc 228 , constructorVars = [] 229 , constructorContext = 230 [ equalPred aVar cVar 231 , equalPred bVar cVar 232 , classPred ''Read [cVar] 233 , classPred ''Show [cVar] 234 ] 235 , constructorFields = 236 [ListT `AppT` cVar, ConT ''Maybe `AppT` cVar] 237 , constructorStrictness = 238 [notStrictAnnot, notStrictAnnot] 239 , constructorVariant = NormalConstructor } 240 ] 241 } 242 ) 243 244showableTest :: IO () 245showableTest = 246 $(do info <- reifyDatatype ''Showable 247 248 let a = mkName "a" 249 250 validateDI info 251 DatatypeInfo 252 { datatypeName = ''Showable 253 , datatypeContext = [] 254 , datatypeVars = [] 255 , datatypeInstTypes = [] 256 , datatypeVariant = Datatype 257 , datatypeCons = 258 [ ConstructorInfo 259 { constructorName = 'Showable 260 , constructorVars = [kindedTV a starK] 261 , constructorContext = [classPred ''Show [VarT a]] 262 , constructorFields = [VarT a] 263 , constructorStrictness = [notStrictAnnot] 264 , constructorVariant = NormalConstructor } 265 ] 266 } 267 ) 268 269recordTest :: IO () 270recordTest = 271 $(do info <- reifyDatatype ''R 272 validateDI info 273 DatatypeInfo 274 { datatypeName = ''R 275 , datatypeContext = [] 276 , datatypeVars = [] 277 , datatypeInstTypes = [] 278 , datatypeVariant = Datatype 279 , datatypeCons = 280 [ ConstructorInfo 281 { constructorName = 'R1 282 , constructorVars = [] 283 , constructorContext = [] 284 , constructorFields = [ConT ''Int, ConT ''Int] 285 , constructorStrictness = [notStrictAnnot, notStrictAnnot] 286 , constructorVariant = RecordConstructor ['field1, 'field2] } 287 ] 288 } 289 ) 290 291gadt2Test :: IO () 292gadt2Test = 293 $(do info <- reifyDatatype ''Gadt2 294 let names = map mkName ["a","b"] 295 [aTvb,bTvb] = map (\v -> kindedTV v starK) names 296 vars@[aVar,bVar] = map VarT names 297 [aSig,bSig] = map (\v -> SigT v starK) vars 298 x = mkName "x" 299 300 con = ConstructorInfo 301 { constructorName = undefined 302 , constructorVars = [] 303 , constructorContext = [] 304 , constructorFields = [] 305 , constructorStrictness = [] 306 , constructorVariant = NormalConstructor } 307 validateDI info 308 DatatypeInfo 309 { datatypeName = ''Gadt2 310 , datatypeContext = [] 311 , datatypeVars = [aTvb, bTvb] 312 , datatypeInstTypes = [aSig, bSig] 313 , datatypeVariant = Datatype 314 , datatypeCons = 315 [ con { constructorName = 'Gadt2c1 316 , constructorContext = [equalPred bVar (AppT ListT aVar)] } 317 , con { constructorName = 'Gadt2c2 318 , constructorContext = [equalPred aVar (AppT ListT bVar)] } 319 , con { constructorName = 'Gadt2c3 320 , constructorVars = [kindedTV x starK] 321 , constructorContext = 322 [equalPred aVar (AppT ListT (VarT x)) 323 ,equalPred bVar (AppT ListT (VarT x))] } ] 324 } 325 ) 326 327voidstosTest :: IO () 328voidstosTest = 329 $(do info <- reifyDatatype ''VoidStoS 330 let g = mkName "g" 331 validateDI info 332 DatatypeInfo 333 { datatypeName = ''VoidStoS 334 , datatypeContext = [] 335 , datatypeVars = [kindedTV g (arrowKCompat starK starK)] 336 , datatypeInstTypes = [SigT (VarT g) (arrowKCompat starK starK)] 337 , datatypeVariant = Datatype 338 , datatypeCons = [] 339 } 340 ) 341 342strictDemoTest :: IO () 343strictDemoTest = 344 $(do info <- reifyDatatype ''StrictDemo 345 validateDI info 346 DatatypeInfo 347 { datatypeName = ''StrictDemo 348 , datatypeContext = [] 349 , datatypeVars = [] 350 , datatypeInstTypes = [] 351 , datatypeVariant = Datatype 352 , datatypeCons = 353 [ ConstructorInfo 354 { constructorName = 'StrictDemo 355 , constructorVars = [] 356 , constructorContext = [] 357 , constructorFields = [ConT ''Int, ConT ''Int, ConT ''Int] 358 , constructorStrictness = [ notStrictAnnot 359 , isStrictAnnot 360 , unpackedAnnot 361 ] 362 , constructorVariant = NormalConstructor } ] 363 } 364 ) 365 366recordVanillaTest :: IO () 367recordVanillaTest = 368 $(do info <- reifyRecord 'gadtrec1a 369 validateCI info gadtRecVanillaCI) 370 371#if MIN_VERSION_template_haskell(2,6,0) 372t43Test :: IO () 373t43Test = 374 $(do [decPlain] <- [d| data T43Plain where MkT43Plain :: T43Plain |] 375 infoPlain <- normalizeDec decPlain 376 validateDI infoPlain 377 DatatypeInfo 378 { datatypeName = mkName "T43Plain" 379 , datatypeContext = [] 380 , datatypeVars = [] 381 , datatypeInstTypes = [] 382 , datatypeVariant = Datatype 383 , datatypeCons = 384 [ ConstructorInfo 385 { constructorName = mkName "MkT43Plain" 386 , constructorVars = [] 387 , constructorContext = [] 388 , constructorFields = [] 389 , constructorStrictness = [] 390 , constructorVariant = NormalConstructor } ] 391 } 392 393 [decFam] <- [d| data instance T43Fam where MkT43Fam :: T43Fam |] 394 infoFam <- normalizeDec decFam 395 validateDI infoFam 396 DatatypeInfo 397 { datatypeName = mkName "T43Fam" 398 , datatypeContext = [] 399 , datatypeVars = [] 400 , datatypeInstTypes = [] 401 , datatypeVariant = DataInstance 402 , datatypeCons = 403 [ ConstructorInfo 404 { constructorName = mkName "MkT43Fam" 405 , constructorVars = [] 406 , constructorContext = [] 407 , constructorFields = [] 408 , constructorStrictness = [] 409 , constructorVariant = NormalConstructor } ] 410 } 411 ) 412 413t58Test :: IO () 414t58Test = 415 $(do [dec] <- [d| data Foo where 416 MkFoo :: a -> Foo |] 417 info <- normalizeDec dec 418 let a = mkName "a" 419 validateDI info 420 DatatypeInfo 421 { datatypeName = mkName "Foo" 422 , datatypeContext = [] 423 , datatypeVars = [] 424 , datatypeInstTypes = [] 425 , datatypeVariant = Datatype 426 , datatypeCons = 427 [ ConstructorInfo 428 { constructorName = mkName "MkFoo" 429 , constructorVars = [plainTV a] 430 , constructorContext = [] 431 , constructorFields = [VarT a] 432 , constructorStrictness = [notStrictAnnot] 433 , constructorVariant = NormalConstructor } ] 434 } 435 ) 436#endif 437 438#if MIN_VERSION_template_haskell(2,7,0) 439dataFamilyTest :: IO () 440dataFamilyTest = 441 $(do info <- reifyDatatype 'DFMaybe 442 let a = mkName "a" 443 validateDI info 444 DatatypeInfo 445 { datatypeName = ''DF 446 , datatypeContext = [] 447 , datatypeVars = [kindedTV a starK] 448 , datatypeInstTypes = [AppT (ConT ''Maybe) (VarT a)] 449 , datatypeVariant = DataInstance 450 , datatypeCons = 451 [ ConstructorInfo 452 { constructorName = 'DFMaybe 453 , constructorVars = [] 454 , constructorContext = [] 455 , constructorFields = [ConT ''Int, ListT `AppT` VarT a] 456 , constructorStrictness = [notStrictAnnot, notStrictAnnot] 457 , constructorVariant = NormalConstructor } ] 458 } 459 ) 460 461ghc78bugTest :: IO () 462ghc78bugTest = 463 $(do info <- reifyDatatype 'DF1 464 let c = mkName "c" 465 cVar = VarT c 466 validateDI info 467 DatatypeInfo 468 { datatypeName = ''DF1 469 , datatypeContext = [] 470 , datatypeVars = [kindedTV c starK] 471 , datatypeInstTypes = [SigT cVar starK] 472 , datatypeVariant = DataInstance 473 , datatypeCons = 474 [ ConstructorInfo 475 { constructorName = 'DF1 476 , constructorVars = [] 477 , constructorContext = [] 478 , constructorFields = [cVar] 479 , constructorStrictness = [notStrictAnnot] 480 , constructorVariant = NormalConstructor } ] 481 } 482 ) 483 484quotedTest :: IO () 485quotedTest = 486 $(do [dec] <- [d| data instance Quoted a = MkQuoted a |] 487 info <- normalizeDec dec 488 let a = mkName "a" 489 aVar = VarT a 490 validateDI info 491 DatatypeInfo 492 { datatypeName = mkName "Quoted" 493 , datatypeContext = [] 494 , datatypeVars = [plainTV a] 495 , datatypeInstTypes = [aVar] 496 , datatypeVariant = DataInstance 497 , datatypeCons = 498 [ ConstructorInfo 499 { constructorName = mkName "MkQuoted" 500 , constructorVars = [] 501 , constructorContext = [] 502 , constructorFields = [aVar] 503 , constructorStrictness = [notStrictAnnot] 504 , constructorVariant = NormalConstructor } ] 505 } 506 ) 507 508polyTest :: IO () 509polyTest = 510 $(do info <- reifyDatatype 'MkPoly 511 let [a,k] = map mkName ["a","k"] 512 kVar = varKCompat k 513 validateDI info 514 DatatypeInfo 515 { datatypeName = ''Poly 516 , datatypeContext = [] 517 , datatypeVars = [ 518#if __GLASGOW_HASKELL__ >= 800 519 kindedTV k starK, 520#endif 521 kindedTV a kVar ] 522 , datatypeInstTypes = [SigT (VarT a) kVar] 523 , datatypeVariant = DataInstance 524 , datatypeCons = 525 [ ConstructorInfo 526 { constructorName = 'MkPoly 527 , constructorVars = [] 528 , constructorContext = [] 529 , constructorFields = [] 530 , constructorStrictness = [] 531 , constructorVariant = NormalConstructor } ] 532 } 533 ) 534 535gadtFamTest :: IO () 536gadtFamTest = 537 $(do info <- reifyDatatype 'MkGadtFam1 538 let names@[c,d,e,q] = map mkName ["c","d","e","q"] 539 [cTvb,dTvb,eTvb,qTvb] = map (\v -> kindedTV v starK) names 540 [cTy,dTy,eTy,qTy] = map VarT names 541 [cSig,dSig] = map (\v -> SigT v starK) [cTy,dTy] 542 validateDI info 543 DatatypeInfo 544 { datatypeName = ''GadtFam 545 , datatypeContext = [] 546 , datatypeVars = [cTvb,dTvb] 547 , datatypeInstTypes = [cSig,dSig] 548 , datatypeVariant = DataInstance 549 , datatypeCons = 550 [ ConstructorInfo 551 { constructorName = 'MkGadtFam1 552 , constructorVars = [] 553 , constructorContext = [] 554 , constructorFields = [dTy,cTy] 555 , constructorStrictness = [notStrictAnnot, notStrictAnnot] 556 , constructorVariant = NormalConstructor } 557 , ConstructorInfo 558 { constructorName = '(:&&:) 559 , constructorVars = [kindedTV e starK] 560 , constructorContext = [equalPred cTy (AppT ListT eTy)] 561 , constructorFields = [eTy,dTy] 562 , constructorStrictness = [notStrictAnnot, notStrictAnnot] 563 , constructorVariant = InfixConstructor } 564 , ConstructorInfo 565 { constructorName = '(:^^:) 566 , constructorVars = [] 567 , constructorContext = [ equalPred cTy (ConT ''Int) 568 , equalPred dTy (ConT ''Int) 569 ] 570 , constructorFields = [ConT ''Int, ConT ''Int] 571 , constructorStrictness = [notStrictAnnot, notStrictAnnot] 572 , constructorVariant = NormalConstructor } 573 , gadtRecFamCI 574 , ConstructorInfo 575 { constructorName = 'MkGadtFam4 576 , constructorVars = [] 577 , constructorContext = [ equalPred cTy dTy 578 , equalPred (ConT ''Int) dTy 579 ] 580 , constructorFields = [dTy] 581 , constructorStrictness = [notStrictAnnot] 582 , constructorVariant = NormalConstructor } 583 , ConstructorInfo 584 { constructorName = 'MkGadtFam5 585 , constructorVars = [kindedTV q starK] 586 , constructorContext = [ equalPred cTy (ConT ''Bool) 587 , equalPred dTy (ConT ''Bool) 588 , equalPred qTy (ConT ''Char) 589 ] 590 , constructorFields = [qTy] 591 , constructorStrictness = [notStrictAnnot] 592 , constructorVariant = NormalConstructor } ] 593 } 594 ) 595 596famLocalDecTest1 :: IO () 597famLocalDecTest1 = 598 $(do [dec] <- [d| data instance FamLocalDec1 Int = FamLocalDec1Int { mochi :: Double } |] 599 info <- normalizeDec dec 600 validateDI info 601 DatatypeInfo 602 { datatypeName = ''FamLocalDec1 603 , datatypeContext = [] 604 , datatypeVars = [] 605 , datatypeInstTypes = [ConT ''Int] 606 , datatypeVariant = DataInstance 607 , datatypeCons = 608 [ ConstructorInfo 609 { constructorName = mkName "FamLocalDec1Int" 610 , constructorVars = [] 611 , constructorContext = [] 612 , constructorFields = [ConT ''Double] 613 , constructorStrictness = [notStrictAnnot] 614 , constructorVariant = RecordConstructor [mkName "mochi"] }] 615 } 616 ) 617 618famLocalDecTest2 :: IO () 619famLocalDecTest2 = 620 $(do [dec] <- [d| data instance FamLocalDec2 Int (a, b) a = FamLocalDec2Int { fm0 :: (b, a), fm1 :: Int } |] 621 info <- normalizeDec dec 622 let names = map mkName ["a", "b"] 623 [aTvb,bTvb] = map plainTV names 624 vars@[aVar,bVar] = map (VarT . mkName) ["a", "b"] 625 validateDI info 626 DatatypeInfo 627 { datatypeName = ''FamLocalDec2 628 , datatypeContext = [] 629 , datatypeVars = [aTvb,bTvb] 630 , datatypeInstTypes = [ConT ''Int, TupleT 2 `AppT` aVar `AppT` bVar, aVar] 631 , datatypeVariant = DataInstance 632 , datatypeCons = 633 [ ConstructorInfo 634 { constructorName = mkName "FamLocalDec2Int" 635 , constructorVars = [] 636 , constructorContext = [] 637 , constructorFields = [TupleT 2 `AppT` bVar `AppT` aVar, ConT ''Int] 638 , constructorStrictness = [notStrictAnnot, notStrictAnnot] 639 , constructorVariant = RecordConstructor [mkName "fm0", mkName "fm1"] }] 640 } 641 ) 642 643recordFamTest :: IO () 644recordFamTest = 645 $(do info <- reifyRecord 'famRec1 646 validateCI info gadtRecFamCI) 647 648t46Test :: IO () 649t46Test = 650 $(do info <- reifyDatatype 'MkT46 651 case info of 652 DatatypeInfo { datatypeCons = [ConstructorInfo { constructorContext = ctxt }]} -> 653 unless (null ctxt) (fail "regression test for ticket #46 failed") 654 _ -> fail "T46 should have exactly one constructor" 655 [| return () |]) 656 657t73Test :: IO () 658t73Test = 659 $(do info <- reifyDatatype 'MkT73 660 let b = mkName "b" 661 bTvb = kindedTV b starK 662 bVar = VarT b 663 validateDI info 664 DatatypeInfo 665 { datatypeName = ''T73 666 , datatypeContext = [] 667 , datatypeVars = [bTvb] 668 , datatypeInstTypes = [ConT ''Int, SigT bVar starK] 669 , datatypeVariant = DataInstance 670 , datatypeCons = 671 [ ConstructorInfo 672 { constructorName = 'MkT73 673 , constructorVars = [] 674 , constructorContext = [] 675 , constructorFields = [bVar] 676 , constructorStrictness = [notStrictAnnot] 677 , constructorVariant = NormalConstructor }] 678 } 679 ) 680#endif 681 682fixityLookupTest :: IO () 683fixityLookupTest = 684 $(do Just (Fixity 6 InfixR) <- reifyFixityCompat '(:**:) 685 [| return () |]) 686 687#if __GLASGOW_HASKELL__ >= 704 688resolvePredSynonymsTest :: IO () 689resolvePredSynonymsTest = 690 $(do info <- reifyDatatype ''PredSynT 691 [cxt1,cxt2,cxt3] <- sequence $ map (mapM resolvePredSynonyms . constructorContext) 692 $ datatypeCons info 693 let mkTest = zipWithM_ (equateCxt "resolvePredSynonymsTest") 694 test1 = mkTest cxt1 [classPred ''Show [ConT ''Int]] 695 test2 = mkTest cxt2 [classPred ''Show [ConT ''Int]] 696 test3 = mkTest cxt3 [equalPred (ConT ''Int) (ConT ''Int)] 697 mapM_ (either fail return) [test1,test2,test3] 698 [| return () |]) 699#endif 700 701reifyDatatypeWithConNameTest :: IO () 702reifyDatatypeWithConNameTest = 703 $(do info <- reifyDatatype 'Just 704 let a = mkName "a" 705 validateDI info 706 DatatypeInfo 707 { datatypeContext = [] 708 , datatypeName = ''Maybe 709 , datatypeVars = [kindedTV a starK] 710 , datatypeInstTypes = [SigT (VarT a) starK] 711 , datatypeVariant = Datatype 712 , datatypeCons = 713 [ ConstructorInfo 714 { constructorName = 'Nothing 715 , constructorVars = [] 716 , constructorContext = [] 717 , constructorFields = [] 718 , constructorStrictness = [] 719 , constructorVariant = NormalConstructor 720 } 721 , justCI 722 ] 723 } 724 ) 725 726reifyConstructorTest :: IO () 727reifyConstructorTest = 728 $(do info <- reifyConstructor 'Just 729 validateCI info justCI) 730 731#if MIN_VERSION_base(4,7,0) 732importedEqualityTest :: IO () 733importedEqualityTest = 734 $(do info <- reifyDatatype ''(:~:) 735 let names@[a,b] = map mkName ["a","b"] 736 [aVar,bVar] = map VarT names 737 k = mkName "k" 738 kKind = varKCompat k 739 validateDI info 740 DatatypeInfo 741 { datatypeContext = [] 742 , datatypeName = ''(:~:) 743 , datatypeVars = [ 744#if __GLASGOW_HASKELL__ >= 800 745 kindedTV k starK, 746#endif 747 kindedTV a kKind, kindedTV b kKind] 748 , datatypeInstTypes = [SigT aVar kKind, SigT bVar kKind] 749 , datatypeVariant = Datatype 750 , datatypeCons = 751 [ ConstructorInfo 752 { constructorName = 'Refl 753 , constructorVars = [] 754 , constructorContext = [equalPred aVar bVar] 755 , constructorFields = [] 756 , constructorStrictness = [] 757 , constructorVariant = NormalConstructor } ] 758 } 759 ) 760#endif 761 762#if MIN_VERSION_template_haskell(2,8,0) 763kindSubstTest :: IO () 764kindSubstTest = 765 $(do k1 <- newName "k1" 766 k2 <- newName "k2" 767 a <- newName "a" 768 let ty = ForallT [kindedTVSpecified a (VarT k1)] [] (VarT a) 769 substTy = applySubstitution (Map.singleton k1 (VarT k2)) ty 770 771 checkFreeVars :: Type -> [Name] -> Q () 772 checkFreeVars t freeVars = 773 unless (freeVariables t == freeVars) $ 774 fail $ "free variables of " ++ show t ++ " should be " ++ show freeVars 775 776 checkFreeVars ty [k1] 777 checkFreeVars substTy [k2] 778 [| return () |]) 779 780t59Test :: IO () 781t59Test = 782 $(do k <- newName "k" 783 a <- newName "a" 784 let proxyAK = ConT (mkName "Proxy") `AppT` SigT (VarT a) (VarT k) 785 -- Proxy (a :: k) 786 expected = ForallT 787#if __GLASGOW_HASKELL__ >= 800 788 [plainTVSpecified k, kindedTVSpecified a (VarT k)] 789#else 790 [kindedTVSpecified a (VarT k)] 791#endif 792 [] proxyAK 793 actual = quantifyType proxyAK 794 unless (expected == actual) $ 795 fail $ "quantifyType does not respect dependency order: " 796 ++ unlines [ "Expected: " ++ pprint expected 797 , "Actual: " ++ pprint actual 798 ] 799 [| return () |]) 800 801t61Test :: IO () 802t61Test = 803 $(do let test :: Type -> Type -> Q () 804 test orig expected = do 805 actual <- resolveTypeSynonyms orig 806 unless (expected == actual) $ 807 fail $ "Type synonym expansion failed: " 808 ++ unlines [ "Expected: " ++ pprint expected 809 , "Actual: " ++ pprint actual 810 ] 811 812 idAppT = (ConT ''Id `AppT`) 813 a = mkName "a" 814 test (SigT (idAppT $ ConT ''Int) (idAppT StarT)) 815 (SigT (ConT ''Int) StarT) 816#if MIN_VERSION_template_haskell(2,10,0) 817 test (ForallT [kindedTVSpecified a (idAppT StarT)] 818 [idAppT (ConT ''Show `AppT` VarT a)] 819 (idAppT $ VarT a)) 820 (ForallT [kindedTVSpecified a StarT] 821 [ConT ''Show `AppT` VarT a] 822 (VarT a)) 823#endif 824#if MIN_VERSION_template_haskell(2,11,0) 825 test (InfixT (idAppT $ ConT ''Int) ''Either (idAppT $ ConT ''Int)) 826 (InfixT (ConT ''Int) ''Either (ConT ''Int)) 827 test (ParensT (idAppT $ ConT ''Int)) 828 (ConT ''Int) 829#endif 830 [| return () |]) 831 832t66Test :: IO () 833t66Test = 834 $(do [dec] <- [d| data Foo a b :: (* -> *) -> * -> * where 835 MkFoo :: a -> b -> f x -> Foo a b f x |] 836 info <- normalizeDec dec 837 let [a,b,f,x] = map mkName ["a","b","f","x"] 838 fKind = arrowKCompat starK starK 839 validateDI info 840 DatatypeInfo 841 { datatypeName = mkName "Foo" 842 , datatypeContext = [] 843 , datatypeVars = [ plainTV a, plainTV b 844 , kindedTV f fKind, kindedTV x starK ] 845 , datatypeInstTypes = [ VarT a, VarT b 846 , SigT (VarT f) fKind, SigT (VarT x) starK ] 847 , datatypeVariant = Datatype 848 , datatypeCons = 849 [ ConstructorInfo 850 { constructorName = mkName "MkFoo" 851 , constructorVars = [] 852 , constructorContext = [] 853 , constructorFields = [VarT a, VarT b, VarT f `AppT` VarT x] 854 , constructorStrictness = [notStrictAnnot, notStrictAnnot, notStrictAnnot] 855 , constructorVariant = NormalConstructor } ] 856 } 857 ) 858 859t80Test :: IO () 860t80Test = do 861 let [k,a,b] = map mkName ["k","a","b"] 862 -- forall k (a :: k) (b :: k). () 863 t = ForallT [ plainTVSpecified k 864 , kindedTVSpecified a (VarT k) 865 , kindedTVSpecified b (VarT k) 866 ] [] (ConT ''()) 867 868 expected, actual :: [Name] 869 expected = [] 870 actual = freeVariables t 871 872 unless (expected == actual) $ 873 fail $ "Bug in ForallT substitution: " 874 ++ unlines [ "Expected: " ++ pprint expected 875 , "Actual: " ++ pprint actual 876 ] 877 return () 878#endif 879 880#if MIN_VERSION_template_haskell(2,11,0) 881t79Test :: IO () 882t79Test = 883 $(do let [a,b,c] = map mkName ["a","b","c"] 884 t = ForallT [kindedTVSpecified a (UInfixT (VarT b) ''(:+:) (VarT c))] [] 885 (ConT ''()) 886 expected = ForallT [kindedTVSpecified a (ConT ''(:+:) `AppT` VarT b `AppT` VarT c)] [] 887 (ConT ''()) 888 actual <- resolveInfixT t 889 unless (expected == actual) $ 890 fail $ "resolveInfixT does not recur into the kinds of " 891 ++ "ForallT type variable binders: " 892 ++ unlines [ "Expected: " ++ pprint expected 893 , "Actual: " ++ pprint actual 894 ] 895 [| return () |]) 896#endif 897 898#if __GLASGOW_HASKELL__ >= 800 899t37Test :: IO () 900t37Test = 901 $(do infoA <- reifyDatatype ''T37a 902 let names@[k,a] = map mkName ["k","a"] 903 [kVar,aVar] = map VarT names 904 kSig = SigT kVar starK 905 aSig = SigT aVar kVar 906 kTvb = kindedTV k starK 907 aTvb = kindedTV a kVar 908 validateDI infoA 909 DatatypeInfo 910 { datatypeContext = [] 911 , datatypeName = ''T37a 912 , datatypeVars = [kTvb, aTvb] 913 , datatypeInstTypes = [kSig, aSig] 914 , datatypeVariant = Datatype 915 , datatypeCons = 916 [ ConstructorInfo 917 { constructorName = 'MkT37a 918 , constructorVars = [] 919 , constructorContext = [equalPred kVar (ConT ''Bool)] 920 , constructorFields = [] 921 , constructorStrictness = [] 922 , constructorVariant = NormalConstructor } ] 923 } 924 925 infoB <- reifyDatatype ''T37b 926 validateDI infoB 927 DatatypeInfo 928 { datatypeContext = [] 929 , datatypeName = ''T37b 930 , datatypeVars = [kTvb, aTvb] 931 , datatypeInstTypes = [aSig] 932 , datatypeVariant = Datatype 933 , datatypeCons = 934 [ ConstructorInfo 935 { constructorName = 'MkT37b 936 , constructorVars = [] 937 , constructorContext = [equalPred kVar (ConT ''Bool)] 938 , constructorFields = [] 939 , constructorStrictness = [] 940 , constructorVariant = NormalConstructor } ] 941 } 942 943 infoC <- reifyDatatype ''T37c 944 validateDI infoC 945 DatatypeInfo 946 { datatypeContext = [] 947 , datatypeName = ''T37c 948 , datatypeVars = [kTvb, aTvb] 949 , datatypeInstTypes = [aSig] 950 , datatypeVariant = Datatype 951 , datatypeCons = 952 [ ConstructorInfo 953 { constructorName = 'MkT37c 954 , constructorVars = [] 955 , constructorContext = [equalPred aVar (ConT ''Bool)] 956 , constructorFields = [] 957 , constructorStrictness = [] 958 , constructorVariant = NormalConstructor } ] 959 } 960 ) 961 962polyKindedExTyvarTest :: IO () 963polyKindedExTyvarTest = 964 $(do info <- reifyDatatype ''T48 965 let [a,x] = map mkName ["a","x"] 966 aVar = VarT a 967 validateDI info 968 DatatypeInfo 969 { datatypeContext = [] 970 , datatypeName = ''T48 971 , datatypeVars = [kindedTV a starK] 972 , datatypeInstTypes = [SigT aVar starK] 973 , datatypeVariant = Datatype 974 , datatypeCons = 975 [ ConstructorInfo 976 { constructorName = 'MkT48 977 , constructorVars = [kindedTV x aVar] 978 , constructorContext = [] 979 , constructorFields = [ConT ''Prox `AppT` VarT x] 980 , constructorStrictness = [notStrictAnnot] 981 , constructorVariant = NormalConstructor } ] 982 } 983 -- Because validateCI uses a type variable substitution to normalize 984 -- away any alpha-renaming differences between constructors, it 985 -- unfortunately does not check if the uses of `a` in datatypeVars and 986 -- constructorVars are the same. We perform this check explicitly here. 987 case info of 988 DatatypeInfo { datatypeVars = [v1] 989 , datatypeCons = 990 [ConstructorInfo { constructorVars = [v2] }] } 991 | a1 <- tvName v1, starK == tvKind v1, VarT a2 <- tvKind v2 992 -> unless (a1 == a2) $ 993 fail $ "Two occurrences of the same variable have different names: " 994 ++ show [a1, a2] 995 [| return () |] 996 ) 997 998t75Test :: IO () 999t75Test = 1000 $(do info <- reifyDatatype ''T75 1001 case datatypeCons info of 1002 [c] -> let datatypeVarTypes = map (VarT . tvName) $ datatypeVars info 1003 constructorVarKinds = map tvKind $ constructorVars c in 1004 unless (datatypeVarTypes == constructorVarKinds) $ 1005 fail $ "Mismatch between datatypeVars and constructorVars' kinds: " 1006 ++ unlines [ "datatypeVars: " 1007 ++ pprint datatypeVarTypes 1008 , "constructorVars' kinds: " 1009 ++ pprint constructorVarKinds 1010 ] 1011 cs -> fail $ "Unexpected number of constructors for T75: " 1012 ++ show (length cs) 1013 [| return () |] 1014 ) 1015#endif 1016 1017#if __GLASGOW_HASKELL__ >= 807 1018resolveTypeSynonymsVKATest :: IO () 1019resolveTypeSynonymsVKATest = 1020 $(do t <- [t| T37b @Bool True |] 1021 t' <- resolveTypeSynonyms t 1022 unless (t == t') $ 1023 fail $ "Type synonym expansion breaks with visible kind application: " 1024 ++ show [t, t'] 1025 [| return () |]) 1026#endif 1027 1028regressionTest44 :: IO () 1029regressionTest44 = 1030 $(do intToInt <- [t| Int -> Int |] 1031 unified <- unifyTypes [intToInt, intToInt] 1032 unless (Map.null unified) (fail "regression test for ticket #44 failed") 1033 [| return () |]) 1034 1035t63Test :: IO () 1036t63Test = 1037 $(do a <- newName "a" 1038 b <- newName "b" 1039 t <- newName "T" 1040 let tauType = ArrowT `AppT` VarT a `AppT` (ArrowT `AppT` VarT b 1041 `AppT` (ConT t `AppT` VarT a)) 1042 sigmaType = ForallT [plainTVSpecified b] [] tauType 1043 expected = ForallT [plainTVSpecified a, plainTVSpecified b] [] tauType 1044 actual = quantifyType sigmaType 1045 unless (expected == actual) $ 1046 fail $ "quantifyType does not collapse consecutive foralls: " 1047 ++ unlines [ "Expected: " ++ pprint expected 1048 , "Actual: " ++ pprint actual 1049 ] 1050 [| return () |]) 1051 1052t70Test :: IO () 1053t70Test = 1054 $(do a <- newName "a" 1055 b <- newName "b" 1056 let [aVar, bVar] = map VarT [a, b] 1057 [aTvb, bTvb] = map plainTV [a, b] 1058 let fvsABExpected = [aTvb, bTvb] 1059 fvsABActual = freeVariablesWellScoped [aVar, bVar] 1060 1061 fvsBAExpected = [bTvb, aTvb] 1062 fvsBAActual = freeVariablesWellScoped [bVar, aVar] 1063 1064 check expected actual = 1065 unless (expected == actual) $ 1066 fail $ "freeVariablesWellScoped does not preserve left-to-right order: " 1067 ++ unlines [ "Expected: " ++ pprint expected 1068 , "Actual: " ++ pprint actual 1069 ] 1070 1071 check fvsABExpected fvsABActual 1072 check fvsBAExpected fvsBAActual 1073 1074 [| return () |]) 1075