content: {-# LANGUAGE TemplateHaskell, RankNTypes, GADTs, PatternSynonyms #-}
  
  module T8761 where
  
  {- Testsuite for pattern synonyms as implemented by ticket #8761 -}
  
  import Control.Monad
  import Language.Haskell.TH
  import System.IO
  
  data Ex         where MkEx       :: forall a. a -> Ex
  data ExProv     where MkExProv   :: forall a. (Show a) => a -> ExProv
  data UnivProv a where MkUnivProv :: forall a. (Show a) => a -> UnivProv a
  
  {- Test manual construction and pretty printing of pattern synonyms -}
  do
    [qx1,qy1,qz1] <- mapM (\i -> newName $ "x" ++ show i) [1,2,3]
    let nm1       = mkName "Q1"
        prefixPat = patSynD nm1 (prefixPatSyn [qx1,qy1,qz1]) unidir
          (tupP [tupP [varP qx1, varP qy1], listP [varP qz1], wildP, wildP])
  
    [qx2,qy2] <- mapM (\i -> newName $ "x" ++ show i) [1,2]
    let nm2      = mkName "Q2"
        infixPat = patSynD nm2 (infixPatSyn qx2 qy2) implBidir
          (tupP [tupP [varP qx2, varP qy2]])
  
    let nm3           = mkName "Q3"
        [qx3,qy3,qz3] = map mkName ["qx3", "qy3", "qz3"]
        patP          = tupP [tupP [varP qx3, varP qy3], listP [varP qz3]]
        patE          = tupE [tupE [varE qx3, varE qy3], listE [varE qz3]]
        cls           = clause ([varP qx3, varP qy3, varP qz3]) (normalB patE) []
        recordPat     = patSynD nm3 (recordPatSyn [qx3,qy3,qz3])
                          (explBidir [cls]) patP
  
    pats <- sequence [prefixPat, infixPat, recordPat]
    -- pretty print the pattern synonyms:
    mapM_ (runIO . hPutStrLn stderr . pprint) pats
    -- splice in the pattern synonyms
    return pats
  
  {- Test prefix pattern synonyms -}
  [d|
   pattern P1 x y z <- ((x,y), [z], _, _)   -- unidirectional pattern
   pattern P2 x y z =  ((x,y), [z])         -- implicit bidirectional pattern
   pattern P3 x y z <- ((x,y), [z]) where   -- explicit bidirectional pattern
     P3 x y z = ((x,y), [z]) |]
  
  {- Test infix pattern synonyms -}
  [d|
   pattern x :*: y <- ((x,_), [y])
   pattern x :+: y =  (x,y)
   pattern x :~: y <- (x,y) where
     x :~: y = (x,y) |]
  
  {- Test record pattern synonyms -}
  [d|
   pattern R1 {x1, y1} <- ((x1,_), [y1])
   getX1 = x1 ((1, 2), [3]) -- should yield 1
   getY1 = y1 ((1, 2), [3]) -- should yield 3
   pattern R2 {x2, y2} =  (x2, [y2])
   pattern R3 {x3, y3} <- (x3, [y3]) where
     R3 x y = (x, [y]) |]
  
  --x1 = "no, no, no"
  --y1 = "no, no, no"
  
  getX1' = x1 ((1, 2), [3]) -- should yield 1
  getY1' = y1 ((1, 2), [3]) -- should yield 3
  
  {- Test splicing unidirectional pattern synonyms with different types -}
  [d|
   pattern P :: Bool
   pattern P <- True
  
   pattern Pe :: () => forall a. a -> Ex
   pattern Pe x <- MkEx x
  
   pattern Pu :: forall a. a -> a
   pattern Pu x <-  x
  
   pattern Pue :: forall a. () => forall b. a -> b -> (a, Ex)
   pattern Pue x y <- (x, MkEx y)
  
   pattern Pur :: forall a. (Num a, Eq a) => a -> [a]
   pattern Pur x <- [x, 1]
  
   pattern Purp :: forall a b. (Num a, Eq a) =>
                   Show b => a -> b -> ([a], UnivProv b)
   pattern Purp x y <- ([x, 1], MkUnivProv y)
  
   pattern Pure :: forall a. (Num a, Eq a) => forall b. a -> b -> ([a], Ex)
   pattern Pure x y <- ([x, 1], MkEx y)
  
   pattern Purep :: forall a. (Num a, Eq a) =>
                   forall b. Show b => a -> b -> ([a], ExProv)
   pattern Purep x y <- ([x, 1], MkExProv y)
  
   pattern Pep :: () => forall a. Show a => a -> ExProv
   pattern Pep x <- MkExProv x
  
   pattern Pup :: forall a. () => Show a => a -> UnivProv a
   pattern Pup x <- MkUnivProv x
  
   pattern Puep :: forall a. () => forall b. (Show b) => a -> b -> (ExProv, a)
   pattern Puep x y <- (MkExProv y, x) |]
  
  {- Test reification of different pattern synonyms and their types -}
  do
    infos <- mapM reify [ 'P, 'Pe, 'Pu, 'Pue, 'Pur, 'Purp
                        , 'Pure, 'Purep, 'Pep, 'Pup, 'Puep ]
    mapM_ (runIO . hPutStrLn stderr . pprint) infos
      -- NB. use stderr rather than stdout, because GHC does not
      -- guarantee to flush stdout after TH code.  In particular when
      -- the output is going to a file, and we're using GHC with the
      -- runtime linker or with -fexternal-interpreter, stdout will not
      -- get flushed.
    [d| theAnswerIs = 42 |]
  
  