{- Tests for the th-desugar package

(c) Richard Eisenberg 2013
rae@cs.brynmawr.edu
-}

{-# LANGUAGE TemplateHaskell, LambdaCase, MagicHash, UnboxedTuples,
             MultiWayIf, ParallelListComp, CPP, BangPatterns,
             ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes,
             DataKinds, PolyKinds, GADTs, MultiParamTypeClasses,
             FunctionalDependencies, FlexibleInstances, StandaloneDeriving,
             DefaultSignatures, ConstraintKinds, GADTs, ViewPatterns,
             TupleSections, NoMonomorphismRestriction, TypeOperators,
             TypeApplications #-}

#if __GLASGOW_HASKELL__ >= 801
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedSums #-}
#endif

#if __GLASGOW_HASKELL__ >= 803
{-# LANGUAGE OverloadedLabels #-}
{-# OPTIONS_GHC -Wno-orphans #-}  -- IsLabel is an orphan
#endif

#if __GLASGOW_HASKELL__ >= 805
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuantifiedConstraints #-}
#endif

#if __GLASGOW_HASKELL__ < 806
{-# LANGUAGE TypeInType #-}
#endif

#if __GLASGOW_HASKELL__ >= 807
{-# LANGUAGE ImplicitParams #-}
#endif

#if __GLASGOW_HASKELL__ >= 809
{-# LANGUAGE StandaloneKindSignatures #-}
#endif

#if __GLASGOW_HASKELL__ >= 900
{-# LANGUAGE QualifiedDo #-}
#endif

#if __GLASGOW_HASKELL__ >= 902
{-# LANGUAGE OverloadedRecordDot #-}
#endif

#if __GLASGOW_HASKELL__ >= 906
{-# LANGUAGE TypeData #-}
#endif

#if __GLASGOW_HASKELL__ >= 907
{-# LANGUAGE TypeAbstractions #-}
#endif

#if __GLASGOW_HASKELL__ >= 909
{-# LANGUAGE RequiredTypeArguments #-}
#endif

{-# OPTIONS_GHC -Wno-missing-signatures -Wno-type-defaults
                -Wno-name-shadowing #-}

module Splices where

import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))
import Data.Char
import qualified Data.Kind as Kind (Type)
import GHC.Exts
import GHC.TypeLits

import Language.Haskell.TH
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Desugar
import Language.Haskell.TH.Syntax (Quasi)
import Data.Generics

#if __GLASGOW_HASKELL__ >= 803
import GHC.OverloadedLabels ( IsLabel(..) )
#endif

import Prelude as P

dsSplice :: Q Exp -> Q Exp
dsSplice expq = expq >>= dsExp >>= (return . expToTH)

dsDecSplice :: Q [Dec] -> Q [Dec]
dsDecSplice decsQ = decsQ >>= dsDecs >>= (return . decsToTH)

testDecSplice :: Int -> Q Exp
testDecSplice n = do
  let dsName  = mkName $ "DsDec.Dec" ++ show n
      regName = mkName $ "Dec.Dec" ++ show n
  infoDs  <- reify dsName
  infoReg <- reify regName
  rolesDs  <- reifyRoles dsName
  rolesReg <- reifyRoles regName
  fixityDs  <- reifyFixity dsName
  fixityReg <- reifyFixity regName
  eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg)

unqualify :: Data a => a -> a
unqualify = everywhere (mkT (mkName . nameBase))

assumeStarT :: Data a => a -> a
assumeStarT = everywhere (assume_spec_t . assume_vis_t . assume_unit_t)
  where
    assume_spec_t :: Typeable a => a -> a
#if __GLASGOW_HASKELL__ >= 900
    assume_spec_t = mkT assume_spec

    assume_spec :: TyVarBndrSpec -> TyVarBndrSpec
    assume_spec (PlainTV n spec)    = KindedTV n spec StarT
    assume_spec (KindedTV n spec k) = KindedTV n spec (assumeStarT k)
#else
    assume_spec_t = id
#endif

    assume_vis_t :: Typeable a => a -> a
#if __GLASGOW_HASKELL__ >= 907
    assume_vis_t = mkT assume_vis

    assume_vis :: TyVarBndrVis -> TyVarBndrVis
    assume_vis (PlainTV n vis)    = KindedTV n vis StarT
    assume_vis (KindedTV n vis k) = KindedTV n vis (assumeStarT k)
#else
    assume_vis_t = id
#endif

    assume_unit_t :: Typeable a => a -> a
    assume_unit_t = mkT assume_unit

    assume_unit :: TyVarBndrUnit -> TyVarBndrUnit
    assume_unit = elimTV (\n   -> kindedTV n StarT)
                         (\n k -> kindedTV n (assumeStarT k))

dropTrailing0s :: Data a => a -> a
dropTrailing0s = everywhere (mkT (mkName . frob . nameBase))
  where
    frob str =
      case str of
        'r':_ -> str
        'R':_ -> str
        _     -> L.dropWhileEnd isDigit str

-- Because th-desugar does not support linear types, we must pretend like
-- MulArrowT does not exist for testing purposes.
-- See Note [Gracefully handling linear types] in L.H.TH.Desugar.Core.
delinearize :: Data a => a -> a
delinearize = everywhere (mkT no_mul)
  where
    no_mul :: Type -> Type
#if __GLASGOW_HASKELL__ >= 900
    no_mul (MulArrowT `AppT` _) = ArrowT
#endif
    no_mul t                    = t

eqTH :: (Data a, Show a) => a -> a -> Bool
eqTH a b = show (unqualify a) == show (unqualify b)

eqTHSplice :: (Quasi q, Data a, Show a) => a -> a -> q Exp
eqTHSplice a b = runQ $
  if a `eqTH` b
  then [| True |]
  else [| False |]

test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |]
test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |]
test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing, Just 19, Nothing]) |]
test4_tuples = [| (\(a, _) (# b, _ #) -> a + b) (1,2) (# 3, 4 #) |]
test5_ifs = [| if (5 > 7) then "foo" else if | Nothing <- Just "bar", True -> "blargh" | otherwise -> "bum" |]
test6_ifs2 = [| if | Nothing <- Nothing, False -> 3 | Just _ <- Just "foo" -> 5 |]
test7_let = [| let { x :: Double; x = 5; f :: Double -> Double; f x = x + 1 } in f (x * 2) + x |]
test8_case = [| case Just False of { Just True -> 1 ; Just _ -> 2 ; Nothing -> 3 } |]
test9_do = [| show $ do { foo <- Just "foo"
                        ; let fool = foo ++ "l"
                        ; L.elemIndex 'o' fool
                        ; x <- L.elemIndex 'l' fool
                        ; return (x + 10) } |]
test10_comp = [| [ (x, x+1) | x <- [1..10], x `mod` 2 == 0 ] |]
test11_parcomp = [| [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,5..20] ] |]
test12_parcomp2 = [| [ (x,y,z) | x <- [1..10], z <- [3..100], x + z `mod` 2 == 0 | y <- [2,5..20] ] |]
test13_sig = [| show (read "[10, 11, 12]" :: [Int]) |]

data Record = MkRecord1 { field1 :: Bool, field2 :: Int }
            | MkRecord2 { field2 :: Int, field3 :: Char }

test14_record = [| let r1 = MkRecord1 { field2 = 5, field1 = False } :| [MkRecord2 { field2 = 6, field3 = 'q' }]
                       r2 = fmap (\r -> r { field2 = 18 }) r1
                       r3 = (NE.head r2) { field1 = True } in
                   fmap (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool
                               MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (NE.cons r3 r2) |]

test15_litp = [| map (\case { 5 -> True ; _ -> False }) [5,6] |]
test16_tupp = [| map (\(x,y,z) -> x + y + z) [(1,2,3),(4,5,6)] |]

data InfixType = Int :+: Bool
  deriving (Show, Eq)

test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |]
test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined, ()] |]
test19_bangp = [| map (\ !() -> 5) [()] |]
test20_asp = [| map (\ a@(b :+: c) -> (if c then b + 1 else b - 1, a)) [5 :+: True, 10 :+: False] |]
test21_wildp = [| zipWith (\_ _ -> 10) [1,2,3] ['a','b','c'] |]
test22_listp = [| map (\ [a,b,c] -> a + b + c) [[1,2,3],[4,5,6]] |]
#if __GLASGOW_HASKELL__ >= 801
test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |]
#endif

test24_fun = [| let f (Just x) = x
                    f Nothing = Nothing in
                f (Just (Just 10)) |]

test25_fun2 = [| let f (Just x)
                       | x > 0 = x
                       | x < 0 = x + 10
                     f Nothing = 0
                     f _ = 18 in
                 map f [Just (-5), Just 5, Just 10, Nothing, Just 0] |]

test26_forall = [| let f :: Num a => a -> a
                       f x = x + 10 in
                   (f 5, f 3.0) |]

test27_kisig = [| let f :: Proxy (a :: Bool) -> ()
                      f _ = () in
                  (f (Proxy :: Proxy 'False), f (Proxy :: Proxy 'True)) |]
test28_tupt = [| let f :: (a,b) -> a
                     f (a,_) = a in
                 map f [(1,'a'),(2,'b')] |]
test29_listt = [| let f :: [[Int]] -> [[Int]]
                      f = map (map (+1)) in
                  map f [ [[1]], [[2]] ] |]
test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> ()
                         f _ _ = () in
                     f Proxy Proxy |]
test31_constraint = [| let f :: Proxy (c :: Kind.Type -> Constraint) -> ()
                           f _ = () in
                       [f (Proxy :: Proxy Eq), f (Proxy :: Proxy Show)] |]
test32_tylit = [| let f :: Proxy (a :: Symbol) -> Proxy (b :: Nat) -> ()
                      f _ _ = () in
                  f (Proxy :: Proxy "Hi there!") (Proxy :: Proxy 10) |]
test33_tvbs = [| let f :: forall a (b :: Kind.Type -> Kind.Type). Monad b => a -> b a
                     f = return in
                 [f 1, f 2] :: [Maybe Int] |]

test34_let_as = [| let a@(x, y) = (5, 6) in
                   show x ++ show y ++ show a |]

type Pair a = (a, a)
test35_expand = [| let f :: Pair a -> a
                       f = fst in
                   f |]

type Constant a b = b
test36_expand = [| let f :: Constant Int (,) Bool Char -> Char
                       f = snd in
                   f |]

test40_wildcards = [| let f :: (Show a, _) => a -> a -> _
                          f x y = if x == y then show x else "bad" in
                      f True False :: String |]

#if __GLASGOW_HASKELL__ >= 801
test41_typeapps = [| let f :: forall a. (a -> Bool) -> Bool
                         f g = g (undefined @_ @a) in
                     f (const True) |]

test42_scoped_tvs = [| let f :: (Read a, Show a) => a -> String -> String
                           f (_ :: b) (x :: String) = show (read x :: b)
                       in f True "True" |]

test43_ubx_sums = [| let f :: (# Bool | String #) -> Bool
                         f (# b |   #) = not b
                         f (#   | c #) = c == "c" in
                     f (# | "a" #) |]
#endif

test44_let_pragma = [| let x :: Int
                           x = 1
                           {-# INLINE x #-}
                       in x |]

test45_empty_record_con = [| let j :: Maybe Int
                                 j = Just{}
                             in case j of
                                Nothing -> j
                                Just{}  -> j |]

#if __GLASGOW_HASKELL__ >= 803
data Label (l :: Symbol) = Get

class Has a l b | a l -> b where
  from :: a -> Label l -> b

data Point = Point Int Int deriving Show

instance Has Point "x" Int where from (Point x _) _ = x
instance Has Point "y" Int where from (Point _ y) _ = y

instance Has a l b => IsLabel l (a -> b) where
  fromLabel x = from x (Get :: Label l)

test46_overloaded_label = [| let p = Point 3 4 in
                             #x p - #y p |]
#endif

test47_do_partial_match = [| do { Just () <- [Nothing]; return () } |]

#if __GLASGOW_HASKELL__ >= 805
test48_quantified_constraints =
  [| let f :: forall f a. (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool
         f = (==)
     in f (Proxy @Int) (Proxy @Int) |]
#endif

#if __GLASGOW_HASKELL__ >= 807
test49_implicit_params = [| let f :: (?x :: Int, ?y :: Int) => (Int, Int)
                                f =
                                  let ?x = ?y
                                      ?y = ?x
                                  in (?x, ?y)
                            in (let ?x = 42
                                    ?y = 27
                                in f) |]

test50_vka = [| let hrefl :: (:~~:) @Bool @Bool 'True 'True
                    hrefl = HRefl
                in hrefl |]
#endif

#if __GLASGOW_HASKELL__ >= 809
test51_tuple_sections =
  [| let f1 :: String -> Char -> (String, Int, Char)
         f1 = (,5,)

         f2 :: String -> Char -> (# String, Int, Char #)
         f2 = (#,5,#)
     in case (#,#) (f1 "a" 'a') (f2 "b" 'b') of
          (#,#) ((,,) _ a _) ((#,,#) _ b _) -> a + b |]
#endif

#if __GLASGOW_HASKELL__ >= 900
test52_qual_do =
  [| P.do x <- [1, 2]
          y@1 <- [x]
          [1, 2]
          P.return y |]
#endif

#if __GLASGOW_HASKELL__ >= 901
test53_vta_in_con_pats =
  [| let f :: Maybe Int -> Int
         f (Just @Int x)  = x
         f (Nothing @Int) = 42
     in f (Just @Int 27) |]
#endif

#if __GLASGOW_HASKELL__ >= 902
data ORD1 = MkORD1 { unORD1 :: Int }
data ORD2 = MkORD2 { unORD2 :: ORD1 }

test54_overloaded_record_dot =
  [| let ord1 :: ORD1
         ord1 = MkORD1 1

         ord2 :: ORD2
         ord2 = MkORD2 ord1

     in (ord2.unORD2.unORD1, (.unORD2.unORD1) ord2) |]
#endif

#if __GLASGOW_HASKELL__ >= 903
test55_opaque_pragma =
  [| let f :: String -> String
         f x = x
         {-# OPAQUE f #-}
     in f "Hello, World!" |]

test56_lambda_cases =
  [| (\cases (Just x) (Just y) -> x ++ y
             _        _        -> "") (Just "Hello") (Just "World") |]
#endif

#if __GLASGOW_HASKELL__ >= 907
test57_typed_th_bracket =
  typedBracketE [| 'x' |]

test58_typed_th_splice =
  typedSpliceE (typedBracketE [| 'y' |])
#endif

#if __GLASGOW_HASKELL__ >= 909
test59_embedded_types_keyword =
  [| let idv :: forall a -> a -> a
         idv (type a) (x :: a) = x :: a

     in idv (type Bool) True |]

test60_embedded_types_no_keyword =
  [| let idv :: forall a -> a -> a
         idv a (x :: a) = x :: a

     in idv Bool True |]

test61_invis_type_pat =
  [| let f :: a -> a
         f @a = id @a

     in f @Bool True |]
#endif

type family TFExpand x
type instance TFExpand Int = Bool
type instance TFExpand (Maybe a) = [a]
test_expand3 = [| let f :: TFExpand Int -> ()
                      f True = () in
                  f |]
test_expand4 = [| let f :: TFExpand (Maybe Bool) -> ()
                      f [True, False] = () in
                  f |]

type family ClosedTF a where
  ClosedTF Int = Bool
  ClosedTF x   = Char

test_expand5 = [| let f :: ClosedTF Int -> ()
                      f True = () in
                  f |]
test_expand6 = [| let f :: ClosedTF Double -> ()
                      f 'x' = () in
                  f |]

#if __GLASGOW_HASKELL__ >= 809
type PolyTF :: forall k. k -> Kind.Type
#endif
type family PolyTF (x :: k) :: Kind.Type where
  PolyTF (x :: Kind.Type) = Bool

test_expand7 = [| let f :: PolyTF Int -> ()
                      f True = () in
                  f |]
test_expand8 = [| let f :: PolyTF IO -> ()
                      f True = () in
                  f |]


test_expand9 = [| let f :: TFExpand (Maybe (IO a)) -> IO ()
                      f actions = sequence_ actions in
                  f |]

type family TFExpandClosed a where
  TFExpandClosed (Maybe a) = [a]

test_expand10 = [| let f :: TFExpandClosed (Maybe (IO a)) -> IO ()
                       f actions = sequence_ actions in
                   f |]

test37_pred = [| let f :: (Read a, (Show a, Num a)) => a -> a
                     f x = read (show x) + x in
                 (f 3, f 4.5) |]

test38_pred2 = [| let f :: a b => Proxy a -> b -> b
                      f _ x = x in
                  (f (Proxy :: Proxy Show) False, f (Proxy :: Proxy Num) (3 :: Int)) |]

test39_eq = [| let f :: (a ~ b) => a -> b
                   f x = x in
               (f ()) |]

dec_test_nums = [1..11] :: [Int]

dectest1 = [d| data Dec1 where
                 Foo :: Dec1
                 Bar :: Int -> Dec1 |]
dectest2 = [d| data Dec2 a where
                 MkDec2 :: forall a b. (Show b, Eq a) => a -> b -> Bool -> Dec2 a |]
dectest3 = [d| data Dec3 a where
                 MkDec3 :: forall a b. { foo :: a, bar :: b } -> Dec3 a
               type role Dec3 nominal
               |]
dectest4 = [d| newtype Dec4 a where
                 MkDec4 :: (a, Int) -> Dec4 a |]
dectest5 = [d| type Dec5 a b = (a b, Maybe b) |]
dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: Kind.Type -> Kind.Type) m2 | m1 -> m2  where
                 lift :: forall a. m1 a -> m2 a
                 type M2 m1 :: Kind.Type -> Kind.Type |]
dectest7 = [d| type family Dec7 a (b :: Kind.Type) (c :: Bool) :: Kind.Type -> Kind.Type |]
dectest8 = [d| type family Dec8 a |]
dectest9 = [d| data family Dec9 a (b :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type |]
dectest10 = [d| type family Dec10 a :: Kind.Type -> Kind.Type where
                  Dec10 Int = Maybe
                  Dec10 Bool = [] |]

data Blarggie a = MkBlarggie Int a
dectest11 = [d| class Dec11 a where
                  meth13 :: a -> a -> Bool
                  default meth13 :: Eq a => a -> a -> Bool
                  meth13 = (==)
              |]
standalone_deriving_test = [d| deriving instance Eq a => Eq (Blarggie a) |]
#if __GLASGOW_HASKELL__ >= 801
deriv_strat_test = [d| deriving stock instance Ord a => Ord (Blarggie a) |]
#endif

dectest12 = [d| data Dec12 a where
                  MkGInt :: Dec12 Int
                  MkGOther :: Dec12 b

              |]

dectest13 = [d| data Dec13 :: (Kind.Type -> Constraint) -> Kind.Type where
                  MkDec13 :: c a => a -> Dec13 c
              |]

dectest14 = [d| data InfixADT = Int `InfixADT` Int |]

dectest15 = [d| infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix`
                data InfixGADT a where
                  (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix
                  (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b]
                  ActuallyPrefix :: Char -> Bool -> InfixGADT Double
                  (:^^:) :: Int -> Int -> Int -> InfixGADT Int
                  (:!!:) :: Char -> Char -> InfixGADT Char |]

class ExCls a
data ExData1 a
data ExData2 a

-- ds_dectest{16,17} demonstrate instance declarations with outermost foralls,
-- a feature which Template Haskell itself does not yet support (see #151).
-- For this reason, the closest we can get to this in TH is to construct
-- equivalent Decs, dectest{16,17}, that drop the outermost foralls. The test
-- suite ensures that this process happens automatically during sweetening by
-- checking that the sweetened versions of ds_dectest{16,17} equal
-- dectest{16,17}.

ds_dectest16 = DInstanceD Nothing (Just [DPlainTV (mkName "a") ()]) []
                (DConT ''ExCls `DAppT`
                  (DConT ''ExData1 `DAppT` DVarT (mkName "a"))) []
dectest16 :: Q [Dec]
dectest16 = return [ InstanceD
                       Nothing
                       [] (ConT ''ExCls `AppT`
                            (ConT ''ExData1 `AppT` VarT (mkName "a"))) [] ]
ds_dectest17 = DStandaloneDerivD Nothing (Just [DPlainTV (mkName "a") ()]) []
                (DConT ''ExCls `DAppT`
                  (DConT ''ExData2 `DAppT` DVarT (mkName "a")))
dectest17 :: Q [Dec]
dectest17 = return [ StandaloneDerivD
#if __GLASGOW_HASKELL__ >= 802
                       Nothing
#endif
                       [] (ConT ''ExCls `AppT`
                            (ConT ''ExData2 `AppT` VarT (mkName "a"))) ]

#if __GLASGOW_HASKELL__ >= 809
dectest18 = [d| data Dec18 :: forall k -> k -> Kind.Type where
                  MkDec18 :: forall k (a :: k). Dec18 k a |]
#endif

#if __GLASGOW_HASKELL__ >= 907
dectest19 = [d| type Dec19 :: forall k. k -> Kind.Type
                data Dec19 @k (a :: k) = MkDec19 k (Proxy a) |]
#endif

#if __GLASGOW_HASKELL__ >= 909
dectest20 = [d| infixr 3 data !@#
                infixr 3 type !@#

                (!@#) :: Bool -> Bool -> Bool
                (!@#) = (&&)

                type family (!@#) :: Bool -> Bool -> Bool |]

dectest21 = [d| {-# SCC dec21 "dec21" #-}
                dec21 :: a -> a
                dec21 x = x |]
#endif

instance_test = [d| instance (Show a, Show b) => Show (a -> b) where
                       show _ = "function" |]

class Dec6 a b where { lift :: a x -> b x; type M2 a }
imp_inst_test1 = [d| instance Dec6 Maybe (Either ()) where
                       lift Nothing = Left ()
                       lift (Just x) = Right x
                       type M2 Maybe = Either () |]

data family Dec9 a (b :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type
imp_inst_test2 = [d| data instance Dec9 Int Maybe a where
                       MkIMB  ::             [a] -> Dec9 Int Maybe a
                       MkIMB2 :: forall a b. b a -> Dec9 Int Maybe a |]
imp_inst_test3 = [d| newtype instance Dec9 Bool m x where
                       MkBMX :: m x -> Dec9 Bool m x |]

type family Dec8 a
imp_inst_test4 = [d| type instance Dec8 Int = Bool |]

-- used for bug8884 test
type family Poly (a :: k) :: Kind.Type
type instance Poly x = Int

flatten_dvald_test = [| let (a,b,c) = ("foo", 4, False) in
                        show a ++ show b ++ show c |]

rec_sel_test = [d| data RecordSel a = Show a =>
                                      MkRecord { recsel1 :: (Int, a)
                                               , recsel2 :: (forall b. b -> a)
                                               , recsel3 :: Bool }
                                    | MkRecord2 { recsel3 :: Bool
                                                , recsel4 :: (a, a) } |]
rec_sel_test_num_sels = 4 :: Int

testRecSelTypes :: Int -> Q Exp
testRecSelTypes n = do
  VarI _ ty1 _ <- reify (mkName ("DsDec.recsel" ++ show n))
  VarI _ ty2 _ <- reify (mkName ("Dec.recsel"   ++ show n))
  let ty1' = return $ unqualify ty1
      ty2' = return $ unqualify ty2
  [| let x :: $ty1'
         x _ = undefined
         y :: $ty2'
         y _ = undefined
     in
     $(return $ VarE $ mkName "hasSameType") (\d -> x d) (\d -> y d) |]


-- used for expand


reifyDecs :: Q [Dec]
reifyDecs = [d|
  -- NB: Use a forall here! If you don't, when you splice r1 in and then reify
  -- it, GHC will add an explicit forall behind the scenes, which will cause an
  -- incongruity with the locally reified declaration (which would lack an
  -- explicit forall).
  r1 :: forall a. a -> a
  r1 x = x

  class R2 a b where
    r3 :: a -> b -> c -> a
    type R4 b a :: Kind.Type
    -- Only define this on GHC 8.0 or later, since TH had trouble quoting
    -- associated type family defaults before then.
    type R4 b a = Either a b
    data R5 a :: Kind.Type

  data R6 a = R7 { r8 :: a -> a, r9 :: Bool }

  instance R2 (R6 a) a where
    r3 = undefined
    type R4 a (R6 a) = a
    data R5 (R6 a) = forall b. Show b => R10 { r11 :: a, naughty :: b }

  type family R12 a b :: Kind.Type

  data family R13 a :: Kind.Type

  data instance R13 Int = R14 { r15 :: Bool }

  r16, r17 :: Int
  (r16, r17) = (5, 6)

  newtype R18 = R19 Bool

  type R20 = Bool
  type family R21 (a :: k) (b :: k) :: k where
#if __GLASGOW_HASKELL__ >= 801
#if __GLASGOW_HASKELL__ >= 807
    forall k (a :: k) (b :: k).
#endif
      R21 (a :: k) (b :: k) = b
#else
    -- Due to GHC Trac #12646, R21 will get reified without kind signatures on
    -- a and b on older GHCs, so we must reflect that here.
    R21 a b = b
#endif
  class XXX a where
    r22 :: a -> a
    r22 = id   -- test #32

  data R23 a = MkR23 { getR23 :: a }

  r23Test :: R23 a -> a
  r23Test (MkR23 { getR23 = x }) = x

#if __GLASGOW_HASKELL__ >= 801
  pattern Point :: Int -> Int -> (Int, Int)
  pattern Point{x, y} = (x, y)

  data T a where
    MkT :: Eq b => a -> b -> T a

  foo :: Show a => a -> Bool
  foo x = show x == "foo"

  pattern P :: Show a => Eq b => b -> T a
  pattern P x <- MkT (foo -> True) x

  pattern HeadC :: a -> [a]
  pattern HeadC x <- x:_ where
    HeadC x = [x]

  class LL f where
    llMeth :: f a -> ()

  instance LL [] where
    llMeth _ = ()

  pattern LLMeth :: LL f => f a
  pattern LLMeth <- (llMeth -> ())

  {-# COMPLETE LLMeth :: [] #-}

  llEx :: [a] -> Int
  llEx LLMeth = 5
#endif

#if __GLASGOW_HASKELL__ >= 805
  newtype Id a = MkId a
    deriving stock Eq

  newtype R24 a = MkR24 [a]
    deriving Eq via (Id [a])
#endif

  class R25 (f :: k -> Kind.Type) where
    r26 :: forall (a :: k). f a

  data R27 (a :: k) = R28 { r29 :: Proxy a }

  class R30 a where
    r31 :: a -> b -> a

#if __GLASGOW_HASKELL__ >= 809
  type R32 :: forall k -> k -> Kind.Type
  type family R32 :: forall k -> k -> Kind.Type where
#endif

  data R33 a where
    R34 :: { r35 :: Int } -> R33 Int

#if __GLASGOW_HASKELL__ >= 906
  type data R36 a = R37 a
  type data R38 a where
    R39 :: forall a. a -> R38 a
#endif

  -- A regression test for #184
  data family x ^^^ y
  data instance x ^^^ y = R40 x y

  -- A regression test for #188
  data R41 a (x :: Maybe a) = R42
  |]

reifyDecsNames :: [Name]
reifyDecsNames = map mkName
  [ "r1"
  , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11"
  , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20"
  , "R21"
  , "r22"
  , "R25", "r26", "R28", "r29"
  , "R30", "r31"
#if __GLASGOW_HASKELL__ >= 809
  , "R32"
#endif
  , "R33", "R34", "r35"
#if __GLASGOW_HASKELL__ >= 906
  , "R36", "R37", "R38", "R39"
#endif
  , "R40"
  , "R41", "R42"
  ]

simplCaseTests :: [Q Exp]
simplCaseTests =
  [ [| map (\a -> case a :: [Int] of
        (_:_:_:_) -> (5 :: Int)
        _         -> 6) [[], [1], [1,2,3]]
     |]
  , [| let foo [] = True
           foo _  = False in (foo [], foo "hi") |]
#if __GLASGOW_HASKELL__ >= 801
  , [| let foo ([] :: String) = True
           foo (_  :: String) = False
        in foo "hello" |]
#endif
  ]

-- These foralls are needed because of bug trac9262, fixed in ghc-7.10.
round_trip_types :: [TypeQ]
round_trip_types =
    [ [t|forall a. a ~ Int => a|]
    , [t|forall a. [a]|]
    , [t|forall a b. (a,b)|] ]

test_exprs :: [Q Exp]
test_exprs = [ test1_sections
             , test2_lampats
             , test3_lamcase
-- see above             , test4_tuples
             , test5_ifs
             , test6_ifs2
             , test7_let
             , test8_case
             , test9_do
             , test10_comp
             , test11_parcomp
             , test12_parcomp2
             , test13_sig
             , test14_record
             , test15_litp
             , test16_tupp
             , test17_infixp
             , test18_tildep
             , test19_bangp
             , test20_asp
             , test21_wildp
             , test22_listp
#if __GLASGOW_HASKELL__ >= 801
             , test23_sigp
#endif
             , test24_fun
             , test25_fun2
             , test26_forall
             , test27_kisig
             , test28_tupt
             , test29_listt
             , test30_promoted
             , test31_constraint
             , test32_tylit
             , test33_tvbs
             , test34_let_as
             , test37_pred
             , test38_pred2
             , test39_eq
#if __GLASGOW_HASKELL__ >= 801
             , test41_typeapps
             , test42_scoped_tvs
             , test43_ubx_sums
#endif
             , test44_let_pragma
             , test45_empty_record_con
#if __GLASGOW_HASKELL__ >= 803
             , test46_overloaded_label
#endif
             , test47_do_partial_match
#if __GLASGOW_HASKELL__ >= 805
             , test48_quantified_constraints
#endif
#if __GLASGOW_HASKELL__ >= 807
             , test49_implicit_params
             , test50_vka
#endif
#if __GLASGOW_HASKELL__ >= 809
             , test51_tuple_sections
#endif
#if __GLASGOW_HASKELL__ >= 900
             , test52_qual_do
#endif
#if __GLASGOW_HASKELL__ >= 901
             , test53_vta_in_con_pats
#endif
#if __GLASGOW_HASKELL__ >= 902
             , test54_overloaded_record_dot
#endif
#if __GLASGOW_HASKELL__ >= 903
             , test55_opaque_pragma
             , test56_lambda_cases
#endif
#if __GLASGOW_HASKELL__ >= 907
             , test57_typed_th_bracket
             , test58_typed_th_splice
#endif
#if __GLASGOW_HASKELL__ >= 909
             , test59_embedded_types_keyword
             , test60_embedded_types_no_keyword
             , test61_invis_type_pat
#endif
             ]
