th-desugar-1.18: Test/Splices.hs
{- 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 |]
test62_embedded_types_lambda_keyword =
[| let idv :: forall a -> a -> a
idv = \(type a) (x :: a) -> x :: a
in idv (type Bool) True |]
test63_embedded_types_case_keyword =
[| let idv :: forall a -> a -> a
idv = \case
(type a) -> id @a
in idv (type Bool) True |]
test64_embedded_types_cases_keyword =
[| let idv :: forall a -> a -> a
idv = \cases
(type a) (x :: a) -> x :: a
in idv (type Bool) True |]
test65_embedded_types_lambda_no_keyword =
[| let idv :: forall a -> a -> a
idv = \a (x :: a) -> x :: a
in idv Bool True |]
test66_embedded_types_case_no_keyword =
[| let idv :: forall a -> a -> a
idv = \case
a -> id @a
in idv Bool True |]
test67_embedded_types_cases_no_keyword =
[| let idv :: forall a -> a -> a
idv = \cases
a (x :: a) -> x :: a
in idv Bool True |]
aux :: (forall a. a -> a) -> (forall a. a -> a)
aux f x = f x
test68_invis_type_pat_lambda =
[| aux (\ @a (x :: a) -> x :: a) @Bool True |]
test69_invis_type_pat_cases =
[| aux (\cases @a (x :: a) -> x :: a) @Bool True |]
#endif
#if __GLASGOW_HASKELL__ >= 911
test70_embedded_forall_invis =
[| let idv :: forall a -> a -> a
idv _ x = x
in idv (forall a. a -> a) id True |]
test71_embedded_forall_vis =
[| let idv :: forall a -> a -> a
idv _ x = x
in idv (forall a -> a -> a) idv Bool True |]
test72_embedded_constraint =
[| let idv :: forall a -> a -> a
idv _ x = x
in idv (forall a. (a ~ Bool) => a -> a) (\x -> not x) False |]
#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
, test62_embedded_types_lambda_keyword
, test63_embedded_types_case_keyword
, test64_embedded_types_cases_keyword
, test65_embedded_types_lambda_no_keyword
, test66_embedded_types_case_no_keyword
, test67_embedded_types_cases_no_keyword
, test68_invis_type_pat_lambda
, test69_invis_type_pat_cases
#endif
#if __GLASGOW_HASKELL__ >= 911
, test70_embedded_forall_invis
, test71_embedded_forall_vis
, test72_embedded_constraint
#endif
]