Ticket #4430: testsuite.patch

File testsuite.patch, 8.8 KB (added by reinerp, 3 years ago)
  • new file tests/ghc-regress/th/TH_unresolvedInfix.hs

    From 989437a214933a63653e2cce118a904852247f3e Mon Sep 17 00:00:00 2001
    From: Reiner Pope <reiner.pope@gmail.com>
    Date: Tue, 19 Jul 2011 15:31:34 +1000
    Subject: [PATCH] Test unresolved infix expressions and patterns
    
    ---
     tests/ghc-regress/th/TH_unresolvedInfix.hs     |  107 ++++++++++++++++++++++++
     tests/ghc-regress/th/TH_unresolvedInfix.stdout |   44 ++++++++++
     tests/ghc-regress/th/TH_unresolvedInfix_Lib.hs |   73 ++++++++++++++++
     tests/ghc-regress/th/all.T                     |    5 +
     4 files changed, 229 insertions(+), 0 deletions(-)
     create mode 100644 tests/ghc-regress/th/TH_unresolvedInfix.hs
     create mode 100644 tests/ghc-regress/th/TH_unresolvedInfix.stdout
     create mode 100644 tests/ghc-regress/th/TH_unresolvedInfix_Lib.hs
    
    diff --git a/tests/ghc-regress/th/TH_unresolvedInfix.hs b/tests/ghc-regress/th/TH_unresolvedInfix.hs
    new file mode 100644
    index 0000000..f7cf81c
    - +  
     1{-# LANGUAGE QuasiQuotes #-} 
     2 
     3module Main where 
     4 
     5import TH_unresolvedInfix_Lib 
     6import Language.Haskell.TH 
     7 
     8-- make test had 7 unexpected failures, 0 unexpected passes 
     9-- make fulltest had 23 unexpected failures, 0 unexpected passes 
     10 
     11 
     12-------------------------------------------------------------------------------- 
     13--                                Expressions                                 -- 
     14-------------------------------------------------------------------------------- 
     15exprs = [ 
     16-------------- Completely-unresolved bindings 
     17  $( n +? (n *? n) ), 
     18  $( (n +? n) *? n ), 
     19  $( n +? (n +? n) ), 
     20  $( (n +? n) +? n ), 
     21  -- VarE version 
     22  $( unresolvedInfixE n plus2 (unresolvedInfixE n plus2 n) ), 
     23  $( unresolvedInfixE (unresolvedInfixE n plus2 n) plus2 n ), 
     24  $( unresolvedInfixE n plus3 (unresolvedInfixE n plus3 n) ), 
     25  $( unresolvedInfixE (unresolvedInfixE n plus3 n) plus3 n ), 
     26 
     27--------------- Completely-resolved bindings 
     28  $( n +! (n *! n) ), 
     29  $( (n +! n) *! n ), 
     30  $( n +! (n +! n) ), 
     31  $( (n +! n) +! n ), 
     32 
     33-------------- Mixed resolved/unresolved 
     34  $( (n +! n) *? (n +? n) ), 
     35  $( (n +? n) *? (n +! n) ), 
     36  $( (n +? n) *! (n +! n) ), 
     37  $( (n +? n) *! (n +? n) ), 
     38 
     39-------------- Parens 
     40  $( ((parensE ((n +? n) *? n)) +? n) *? n ), 
     41  $( (parensE (n +? n)) *? (parensE (n +? n)) ), 
     42  $( parensE ((n +? n) *? (n +? n)) ), 
     43 
     44-------------- Sections 
     45  $( infixE (Just $ n +? n) plus Nothing ) N, 
     46  -- see B.hs for the (non-compiling) other version of the above 
     47  $( infixE Nothing plus (Just $ parensE $ unresolvedInfixE n plus n) ) N 
     48  ] 
     49 
     50-------------------------------------------------------------------------------- 
     51--                                  Patterns                                  -- 
     52-------------------------------------------------------------------------------- 
     53patterns = [ 
     54-------------- Completely-unresolved patterns 
     55  case N :+ (N :* N) of 
     56    [p1|unused|] -> True, 
     57  case N :+ (N :* N) of 
     58    [p2|unused|] -> True, 
     59  case (N :+ N) :+ N of 
     60    [p3|unused|] -> True, 
     61  case (N :+ N) :+ N of 
     62    [p4|unused|] -> True, 
     63-------------- Completely-resolved patterns 
     64  case N :+ (N :* N) of 
     65    [p5|unused|] -> True, 
     66  case (N :+ N) :* N of 
     67    [p6|unused|] -> True, 
     68  case N :+ (N :+ N) of 
     69    [p7|unused|] -> True, 
     70  case (N :+ N) :+ N of 
     71    [p8|unused|] -> True, 
     72-------------- Mixed resolved/unresolved 
     73  case ((N :+ N) :* N) :+ N of 
     74    [p9|unused|] -> True, 
     75  case N :+ (N :* (N :+ N)) of 
     76    [p10|unused|] -> True, 
     77  case (N :+ N) :* (N :+ N) of 
     78    [p11|unused|] -> True, 
     79  case (N :+ N) :* (N :+ N) of 
     80    [p12|unused|] -> True, 
     81-------------- Parens 
     82  case (N :+ (N :* N)) :+ (N :* N) of 
     83    [p13|unused|] -> True, 
     84  case (N :+ N) :* (N :+ N) of 
     85    [p14|unused|] -> True, 
     86  case (N :+ (N :* N)) :+ N of 
     87    [p15|unused|] -> True 
     88 ] 
     89 
     90main = do 
     91  mapM_ print exprs 
     92  mapM_ print patterns 
     93  -- check that there are no Parens or UnresolvedInfixes in the output 
     94  runQ [|N :* N :+ N|] >>= print 
     95  runQ [|(N :* N) :+ N|] >>= print 
     96  runQ [p|N :* N :+ N|] >>= print 
     97  runQ [p|(N :* N) :+ N|] >>= print 
     98 
     99  -- pretty-printing of unresolved infix expressions 
     100  let ne = ConE $ mkName "N" 
     101      np = ConP (mkName "N") [] 
     102      plusE = ConE (mkName ":+") 
     103      plusP = (mkName ":+") 
     104  putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UnresolvedInfixE ne plusE (UnresolvedInfixE ne plusE ne))) 
     105  putStrLn $ pprint (ParensE ne) 
     106  putStrLn $ pprint (InfixP np plusP (UnresolvedInfixP np plusP (UnresolvedInfixP np plusP np))) 
     107  putStrLn $ pprint (ParensP np) 
  • new file tests/ghc-regress/th/TH_unresolvedInfix.stdout

    diff --git a/tests/ghc-regress/th/TH_unresolvedInfix.stdout b/tests/ghc-regress/th/TH_unresolvedInfix.stdout
    new file mode 100644
    index 0000000..45534c2
    - +  
     1(N :+ (N :* N)) 
     2(N :+ (N :* N)) 
     3((N :+ N) :+ N) 
     4((N :+ N) :+ N) 
     5((N :+ N) :+ N) 
     6((N :+ N) :+ N) 
     7((N :+ N) :+ N) 
     8((N :+ N) :+ N) 
     9(N :+ (N :* N)) 
     10((N :+ N) :* N) 
     11(N :+ (N :+ N)) 
     12((N :+ N) :+ N) 
     13(((N :+ N) :* N) :+ N) 
     14(N :+ (N :* (N :+ N))) 
     15((N :+ N) :* (N :+ N)) 
     16((N :+ N) :* (N :+ N)) 
     17((N :+ (N :* N)) :+ (N :* N)) 
     18((N :+ N) :* (N :+ N)) 
     19((N :+ (N :* N)) :+ N) 
     20((N :+ N) :+ N) 
     21(N :+ (N :+ N)) 
     22True 
     23True 
     24True 
     25True 
     26True 
     27True 
     28True 
     29True 
     30True 
     31True 
     32True 
     33True 
     34True 
     35True 
     36True 
     37InfixE (Just (InfixE (Just (ConE TH_unresolvedInfix_Lib.N)) (ConE TH_unresolvedInfix_Lib.:*) (Just (ConE TH_unresolvedInfix_Lib.N)))) (ConE TH_unresolvedInfix_Lib.:+) (Just (ConE TH_unresolvedInfix_Lib.N)) 
     38InfixE (Just (InfixE (Just (ConE TH_unresolvedInfix_Lib.N)) (ConE TH_unresolvedInfix_Lib.:*) (Just (ConE TH_unresolvedInfix_Lib.N)))) (ConE TH_unresolvedInfix_Lib.:+) (Just (ConE TH_unresolvedInfix_Lib.N)) 
     39InfixP (InfixP (ConP TH_unresolvedInfix_Lib.N []) TH_unresolvedInfix_Lib.:* (ConP TH_unresolvedInfix_Lib.N [])) TH_unresolvedInfix_Lib.:+ (ConP TH_unresolvedInfix_Lib.N []) 
     40InfixP (InfixP (ConP TH_unresolvedInfix_Lib.N []) TH_unresolvedInfix_Lib.:* (ConP TH_unresolvedInfix_Lib.N [])) TH_unresolvedInfix_Lib.:+ (ConP TH_unresolvedInfix_Lib.N []) 
     41N :+ (N :+ N :+ N) 
     42(N) 
     43N :+ (N :+ N :+ N) 
     44(N) 
  • new file tests/ghc-regress/th/TH_unresolvedInfix_Lib.hs

    diff --git a/tests/ghc-regress/th/TH_unresolvedInfix_Lib.hs b/tests/ghc-regress/th/TH_unresolvedInfix_Lib.hs
    new file mode 100644
    index 0000000..639af07
    - +  
     1module TH_unresolvedInfix_Lib where 
     2 
     3import Language.Haskell.TH 
     4import Language.Haskell.TH.Lib 
     5import Language.Haskell.TH.Quote 
     6 
     7infixl 6 :+ 
     8infixl 7 :* 
     9 
     10data Tree = N 
     11  | Tree :+ Tree  
     12  | Tree :* Tree  
     13 
     14-- custom instance, including redundant parentheses 
     15instance Show Tree where 
     16  show N = "N" 
     17  show (a :+ b) = "(" ++ show a ++ " :+ " ++ show b ++ ")" 
     18  show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")" 
     19 
     20-- VarE versions 
     21infixl 6 +: 
     22infixl 7 *: 
     23(+:) = (:+) 
     24(*:) = (:*) 
     25 
     26n = conE (mkName "N") 
     27plus = conE (mkName ":+") 
     28times = conE (mkName ":*") 
     29 
     30a +? b = unresolvedInfixE a plus b 
     31a *? b = unresolvedInfixE a times b 
     32a +! b = infixApp a plus b 
     33a *! b = infixApp a times b 
     34 
     35plus2 = varE (mkName "+:") 
     36times2 = varE (mkName "*:") 
     37plus3 = conE ('(:+)) 
     38 
     39 
     40-------------------------------------------------------------------------------- 
     41--                                  Patterns                                  -- 
     42-------------------------------------------------------------------------------- 
     43-- The only way to test pattern splices is using QuasiQuotation 
     44mkQQ pat = QuasiQuoter undefined (const pat) undefined undefined 
     45p = conP (mkName "N") [] 
     46plus' = mkName ":+" 
     47times' = mkName ":*" 
     48 
     49a ^+? b = unresolvedInfixP a plus' b 
     50a ^*? b = unresolvedInfixP a times' b 
     51a ^+! b = infixP a plus' b 
     52a ^*! b = infixP a times' b 
     53 
     54-------------- Completely-unresolved patterns 
     55p1 = mkQQ ( p ^+? (p ^*? p) ) 
     56p2 = mkQQ ( (p ^+? p) ^*? p ) 
     57p3 = mkQQ ( p ^+? (p ^+? p) ) 
     58p4 = mkQQ ( (p ^+? p) ^+? p ) 
     59-------------- Completely-resolved patterns 
     60p5 = mkQQ ( p ^+! (p ^*! p) ) 
     61p6 = mkQQ ( (p ^+! p) ^*! p ) 
     62p7 = mkQQ ( p ^+! (p ^+! p) ) 
     63p8 = mkQQ ( (p ^+! p) ^+! p ) 
     64-------------- Mixed resolved/unresolved 
     65p9 = mkQQ ( (p ^+! p) ^*? (p ^+? p) ) 
     66p10 = mkQQ ( (p ^+? p) ^*? (p ^+! p) ) 
     67p11 = mkQQ ( (p ^+? p) ^*! (p ^+! p) ) 
     68p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) ) 
     69-------------- Parens 
     70p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p ) 
     71p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) ) 
     72p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) ) 
     73 
  • tests/ghc-regress/th/all.T

    diff --git a/tests/ghc-regress/th/all.T b/tests/ghc-regress/th/all.T
    index 47ac833..07fa91c 100644
    a b test('T4949', normal, compile, ['-v0']) 
    181181test('T5126', normal, compile, ['-v0']) 
    182182test('T5217', normal, compile, ['-v0 -dsuppress-uniques -ddump-splices']) 
    183183test('T5037', normal, compile, ['-v0']) 
     184 
     185test('TH_unresolvedInfix', 
     186     extra_clean(['TH_unresolvedInfix_Lib.hi', 'TH_unresolvedInfix_Lib.o']), 
     187     multimod_compile_and_run, 
     188     ['TH_unresolvedInfix.hs', '-v0'])