{- Tests for the th-desugar package
(c) Richard Eisenberg 2013
rae@cs.brynmawr.edu
-}
{-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP,
RankNTypes, TypeFamilies,
DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses,
FlexibleInstances, ExistentialQuantification,
ScopedTypeVariables, GADTs, ViewPatterns, TupleSections,
TypeOperators #-}
{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns
-fno-warn-unused-matches -fno-warn-type-defaults
-fno-warn-missing-signatures -fno-warn-unused-do-bind
-fno-warn-missing-fields -fno-warn-incomplete-record-updates #-}
#if __GLASGOW_HASKELL__ >= 711
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-}
#endif
#if __GLASGOW_HASKELL__ >= 805
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuantifiedConstraints #-}
#endif
#if __GLASGOW_HASKELL__ >= 809
{-# LANGUAGE StandaloneKindSignatures #-}
#endif
module Main where
import Prelude hiding ( exp )
import Test.HUnit
import Test.Hspec hiding ( runIO )
-- import Test.Hspec.HUnit
import Splices
import qualified DsDec
import qualified Dec
import Dec ( RecordSel )
import ReifyTypeCUSKs
import ReifyTypeSigs
import Language.Haskell.TH.Desugar
import qualified Language.Haskell.TH.Desugar.OSet as OS
import Language.Haskell.TH.Desugar.Expand ( expandUnsoundly )
import Language.Haskell.TH
import qualified Language.Haskell.TH.Syntax as Syn ( lift )
import Control.Monad
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import qualified Data.Map as M
import Data.Proxy
#if __GLASGOW_HASKELL__ >= 900
import Prelude as P
#endif
-- |
-- Convert a HUnit test suite to a spec. This can be used to run existing
-- HUnit tests with Hspec.
fromHUnitTest :: Test -> Spec
-- copied from https://github.com/hspec/hspec/blob/master/hspec-contrib/src/Test/Hspec/Contrib/HUnit.hs
fromHUnitTest t = case t of
TestList xs -> mapM_ go xs
x -> go x
where
go :: Test -> Spec
go t_ = case t_ of
TestLabel s (TestCase e) -> it s e
TestLabel s (TestList xs) -> describe s (mapM_ go xs)
TestLabel s x -> describe s (go x)
TestList xs -> describe "<unlabeled>" (mapM_ go xs)
TestCase e -> it "<unlabeled>" e
tests :: Test
tests = test [ "sections" ~: $test1_sections @=? $(dsSplice test1_sections)
, "lampats" ~: $test2_lampats @=? $(dsSplice test2_lampats)
, "lamcase" ~: $test3_lamcase @=? $(dsSplice test3_lamcase)
-- Must fix nested pattern-matching for this to work. Argh.
-- , "tuples" ~: $test4_tuples @=? $(dsSplice test4_tuples)
, "ifs" ~: $test5_ifs @=? $(dsSplice test5_ifs)
, "ifs2" ~: $test6_ifs2 @=? $(dsSplice test6_ifs2)
, "let" ~: $test7_let @=? $(dsSplice test7_let)
, "case" ~: $test8_case @=? $(dsSplice test8_case)
, "do" ~: $test9_do @=? $(dsSplice test9_do)
, "comp" ~: $test10_comp @=? $(dsSplice test10_comp)
, "parcomp" ~: $test11_parcomp @=? $(dsSplice test11_parcomp)
, "parcomp2" ~: $test12_parcomp2 @=? $(dsSplice test12_parcomp2)
, "sig" ~: $test13_sig @=? $(dsSplice test13_sig)
, "record" ~: $test14_record @=? $(dsSplice test14_record)
, "litp" ~: $test15_litp @=? $(dsSplice test15_litp)
, "tupp" ~: $test16_tupp @=? $(dsSplice test16_tupp)
, "infixp" ~: $test17_infixp @=? $(dsSplice test17_infixp)
, "tildep" ~: $test18_tildep @=? $(dsSplice test18_tildep)
, "bangp" ~: $test19_bangp @=? $(dsSplice test19_bangp)
, "asp" ~: $test20_asp @=? $(dsSplice test20_asp)
, "wildp" ~: $test21_wildp @=? $(dsSplice test21_wildp)
, "listp" ~: $test22_listp @=? $(dsSplice test22_listp)
#if __GLASGOW_HASKELL__ >= 801
, "sigp" ~: $test23_sigp @=? $(dsSplice test23_sigp)
#endif
, "fun" ~: $test24_fun @=? $(dsSplice test24_fun)
, "fun2" ~: $test25_fun2 @=? $(dsSplice test25_fun2)
, "forall" ~: $test26_forall @=? $(dsSplice test26_forall)
, "kisig" ~: $test27_kisig @=? $(dsSplice test27_kisig)
, "tupt" ~: $test28_tupt @=? $(dsSplice test28_tupt)
, "listt" ~: $test29_listt @=? $(dsSplice test29_listt)
, "promoted" ~: $test30_promoted @=? $(dsSplice test30_promoted)
, "constraint" ~: $test31_constraint @=? $(dsSplice test31_constraint)
, "tylit" ~: $test32_tylit @=? $(dsSplice test32_tylit)
, "tvbs" ~: $test33_tvbs @=? $(dsSplice test33_tvbs)
, "let_as" ~: $test34_let_as @=? $(dsSplice test34_let_as)
#if __GLASGOW_HASKELL__ >= 709
, "pred" ~: $test37_pred @=? $(dsSplice test37_pred)
, "pred2" ~: $test38_pred2 @=? $(dsSplice test38_pred2)
, "eq" ~: $test39_eq @=? $(dsSplice test39_eq)
#endif
#if __GLASGOW_HASKELL__ >= 711
, "wildcard" ~: $test40_wildcards@=? $(dsSplice test40_wildcards)
#endif
#if __GLASGOW_HASKELL__ >= 801
, "typeapps" ~: $test41_typeapps @=? $(dsSplice test41_typeapps)
, "scoped_tvs" ~: $test42_scoped_tvs @=? $(dsSplice test42_scoped_tvs)
, "ubx_sums" ~: $test43_ubx_sums @=? $(dsSplice test43_ubx_sums)
#endif
, "let_pragma" ~: $test44_let_pragma @=? $(dsSplice test44_let_pragma)
-- , "empty_rec" ~: $test45_empty_record_con @=? $(dsSplice test45_empty_record_con)
-- This one can't be tested by this means, because it contains an "undefined"
#if __GLASGOW_HASKELL__ >= 803
, "over_label" ~: $test46_overloaded_label @=? $(dsSplice test46_overloaded_label)
#endif
, "do_partial_match" ~: $test47_do_partial_match @=? $(dsSplice test47_do_partial_match)
#if __GLASGOW_HASKELL__ >= 805
, "quantified_constraints" ~: $test48_quantified_constraints @=? $(dsSplice test48_quantified_constraints)
#endif
#if __GLASGOW_HASKELL__ >= 807
, "implicit_params" ~: $test49_implicit_params @=? $(dsSplice test49_implicit_params)
, "vka" ~: $test50_vka @=? $(dsSplice test50_vka)
#endif
#if __GLASGOW_HASKELL__ >= 809
, "tuple_sections" ~: $test51_tuple_sections @=? $(dsSplice test51_tuple_sections)
#endif
#if __GLASGOW_HASKELL__ >= 900
, "qual_do" ~: $test52_qual_do @=? $(dsSplice test52_qual_do)
#endif
#if __GLASGOW_HASKELL__ >= 901
, "vta_in_con_pats" ~: $test53_vta_in_con_pats @=? $(dsSplice test53_vta_in_con_pats)
#endif
#if __GLASGOW_HASKELL__ >= 902
, "overloaded_record_dot" ~: $test54_overloaded_record_dot @=? $(dsSplice test54_overloaded_record_dot)
#endif
]
test35a = $test35_expand
test35b = $(test35_expand >>= dsExp >>= expand >>= return . expToTH)
test36a = $test36_expand
test36b = $(test36_expand >>= dsExp >>= expand >>= return . expToTH)
test_e3a = $test_expand3
test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH)
test_e4a = $test_expand4
test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH)
test_e5a = $test_expand5
test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH)
test_e6a = $test_expand6
test_e6b = $(test_expand6 >>= dsExp >>= expand >>= return . expToTH)
test_e7a = $test_expand7
test_e7b = $(test_expand7 >>= dsExp >>= expand >>= return . expToTH)
test_e7c = $(test_expand7 >>= dsExp >>= expandUnsoundly >>= return . expToTH)
#if __GLASGOW_HASKELL__ < 801
test_e8a = $(test_expand8 >>= dsExp >>= expand >>= return . expToTH)
-- This won't expand on recent GHCs now that GHC Trac #8953 is fixed for
-- closed type families.
#endif
test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH)
#if __GLASGOW_HASKELL__ >= 709
test_e9a = $test_expand9 -- requires GHC #9262
test_e9b = $(test_expand9 >>= dsExp >>= expand >>= return . expToTH)
#endif
hasSameType :: a -> a -> Bool
hasSameType _ _ = True
test_expand :: Bool
test_expand = and [ hasSameType test35a test35b
, hasSameType test36a test36b
, hasSameType test_e3a test_e3b
, hasSameType test_e4a test_e4b
, hasSameType test_e5a test_e5b
, hasSameType test_e6a test_e6b
, hasSameType test_e7a test_e7b
, hasSameType test_e7a test_e7c
#if __GLASGOW_HASKELL__ < 801
, hasSameType test_e8a test_e8a
#endif
, hasSameType test_e8b test_e8b
#if __GLASGOW_HASKELL__ >= 709
, hasSameType test_e9a test_e9b
#endif
]
test_dec :: [Bool]
test_dec = $(do bools <- mapM testDecSplice dec_test_nums
return $ ListE bools)
$( do fuzzType <- mkTypeName "Fuzz"
fuzzData <- mkDataName "Fuzz"
let tySynDecs = TySynD (mkName "FuzzSyn") [] (ConT fuzzType)
dataSynDecs = TySynD (mkName "FuzzDataSyn") [] (ConT fuzzData)
fuzzDecs <- [d| data Fuzz = Fuzz |]
return $ tySynDecs : dataSynDecs : fuzzDecs )
test_mkName :: Bool
test_mkName = and [ hasSameType (Proxy :: Proxy FuzzSyn) (Proxy :: Proxy Fuzz)
, hasSameType (Proxy :: Proxy FuzzDataSyn) (Proxy :: Proxy 'Fuzz) ]
test_bug8884 :: Bool
test_bug8884 = $(do info <- reify ''Poly
dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann))
(Just [DTySynInstD (DTySynEqn _ lhs _rhs)]))
<- dsInfo info
let isTypeKind (DConT n) = isTypeKindName n
isTypeKind _ = False
case (isTypeKind resK, lhs) of
#if __GLASGOW_HASKELL__ < 709
(True, _ `DAppT` DVarT _) -> [| True |]
#else
(True, _ `DAppT` DSigT (DVarT _) (DVarT _)) -> [| True |]
#endif
_ -> do
runIO $ do
putStrLn "Failed bug8884 test:"
putStrLn $ show dinfo
[| False |] )
flatten_dvald :: Bool
flatten_dvald = let s1 = $(flatten_dvald_test)
s2 = $(do expr <- flatten_dvald_test
DLetE ddecs dexpr <- dsExp expr
flattened <- fmap concat $ mapM flattenDValD ddecs
return $ expToTH $ DLetE flattened dexpr ) in
s1 == s2
test_rec_sels :: Bool
test_rec_sels = and $(do bools <- mapM testRecSelTypes [1..rec_sel_test_num_sels]
return $ ListE bools)
test_standalone_deriving :: Bool
#if __GLASGOW_HASKELL__ >= 709
test_standalone_deriving = (MkBlarggie 5 'x') == (MkBlarggie 5 'x')
#else
test_standalone_deriving = True
#endif
test_deriving_strategies :: Bool
#if __GLASGOW_HASKELL__ >= 801
test_deriving_strategies = compare (MkBlarggie 5 'x') (MkBlarggie 5 'x') == EQ
#else
test_deriving_strategies = True
#endif
test_local_tyfam_expansion :: Bool
test_local_tyfam_expansion =
$(do fam_name <- newName "Fam"
let orig_ty = DConT fam_name
exp_ty <- withLocalDeclarations
(decsToTH [ DOpenTypeFamilyD (DTypeFamilyHead fam_name [] DNoSig Nothing)
, DTySynInstD (DTySynEqn Nothing
(DConT fam_name) (DConT ''Int)) ])
(expandType orig_ty)
orig_ty `eqTHSplice` exp_ty)
test_stuck_tyfam_expansion :: Bool
test_stuck_tyfam_expansion =
$(do fam_name <- newName "F"
x <- newName "x"
k <- newName "k"
let orig_ty = DConT fam_name `DAppT` DConT '() -- F '()
exp_ty <- withLocalDeclarations
(decsToTH [ -- type family F (x :: k) :: k
DOpenTypeFamilyD
(DTypeFamilyHead fam_name
[DKindedTV x () (DVarT k)]
(DKindSig (DVarT k))
Nothing)
-- type instance F (x :: ()) = x
, DTySynInstD
(DTySynEqn Nothing
(DConT fam_name `DAppT`
DSigT (DVarT x) (DConT ''()))
(DVarT x))
])
(expandType orig_ty)
orig_ty `eqTHSplice` exp_ty)
test_t85 :: Bool
test_t85 =
$(do let orig_ty =
(DConT ''Constant `DAppT` DConT ''Int `DAppT` DConT 'True)
`DSigT` (DConT ''Constant `DAppT` DConT ''Char `DAppT` DConT ''Bool)
expected_ty = DConT 'True `DSigT` DConT ''Bool
expanded_ty <- expandType orig_ty
expected_ty `eqTHSplice` expanded_ty)
test_t92 :: Bool
test_t92 =
$(do a <- newName "a"
f <- newName "f"
let t = DForallT (DForallInvis [DPlainTV f SpecifiedSpec])
(DVarT f `DAppT` DVarT a)
toposortTyVarsOf [t] `eqTHSplice` [DPlainTV a ()])
test_t97 :: Bool
test_t97 =
$(do a <- newName "a"
k <- newName "k"
let orig_ty = DForallT
(DForallInvis
[DKindedTV a SpecifiedSpec
(DConT ''Constant `DAppT` DConT ''Int
`DAppT` DVarT k)])
(DVarT a)
expected_ty = DForallT (DForallInvis
[DKindedTV a SpecifiedSpec (DVarT k)])
(DVarT a)
expanded_ty <- expandType orig_ty
expected_ty `eqTHSplice` expanded_ty)
test_getDataD_kind_sig :: Bool
test_getDataD_kind_sig =
#if __GLASGOW_HASKELL__ >= 800
3 == $(do data_name <- newName "TestData"
a <- newName "a"
let type_kind = DConT typeKindName
data_kind_sig = DArrowT `DAppT` type_kind `DAppT`
(DArrowT `DAppT` type_kind `DAppT` type_kind)
(tvbs, _) <- withLocalDeclarations
[decToTH (DDataD Data [] data_name [DPlainTV a ()]
(Just data_kind_sig) [] [])]
(getDataD "th-desugar: Impossible" data_name)
[| $(Syn.lift (length tvbs)) |])
#else
True -- DataD didn't have the ability to store kind signatures prior to GHC 8.0
#endif
test_t100 :: Bool
test_t100 =
#if __GLASGOW_HASKELL__ >= 800
$(do decs <- [d| data T b where
MkT :: forall a. { unT :: a } -> T a |]
info <- withLocalDeclarations decs (dsReify (mkName "unT"))
let -- forall a. T a -> a
exp_ty = DForallT (DForallInvis [DPlainTV (mkName "a") SpecifiedSpec]) $
DArrowT `DAppT` (DConT (mkName "T") `DAppT` DVarT (mkName "a"))
`DAppT` DVarT (mkName "a")
case info of
Just (DVarI _ actual_ty _) -> exp_ty `eqTHSplice` actual_ty
_ -> [| False |])
#else
True -- RecGadtC didn't exist prior to GHC 8.0, so the quote above will
-- normalize to `data T b = MkT { unT :: b }`. This defeats the point of
-- this test, and to make things worse, this will cause `dsReify` to
-- return a different type for unT (forall b. T b -> b). Let's just not
-- bother testing this on pre-8.0 GHCs.
#endif
test_t102 :: [Bool]
test_t102 =
$(do decs1 <- [d| data Foo x where MkFoo :: forall a. { unFoo :: a } -> Foo a |]
let b1 = withLocalDeclarations decs1 $ do
[DDataD _ _ _ _ _ cons1 _] <- dsDecs decs1
recs1 <- getRecordSelectors cons1
(length recs1 `div` 2) `eqTHSplice` 1
decs2 <- [d| data HList l where
Nil :: HList '[]
(:>) :: { hhead :: x, htail :: HList xs } -> HList (x ': xs) |]
let b2 = withLocalDeclarations decs2 $ do
[DDataD _ _ _ _ _ cons2 _] <- dsDecs decs2
recs2 <- getRecordSelectors cons2
(length recs2 `div` 2) `eqTHSplice` 2
[| [$b1, $b2] |])
test_t103 :: Bool
test_t103 =
#if __GLASGOW_HASKELL__ >= 800
$(do decs <- [d| data P (a :: k) = MkP |]
[DDataD _ _ _ _ _ [DCon tvbs _ _ _ _] _] <- dsDecs decs
case tvbs of
[DPlainTV k SpecifiedSpec, DKindedTV a SpecifiedSpec (DVarT k')]
| nameBase k == "k"
, nameBase a == "a"
, k == k'
-> [| True |]
| otherwise
-> [| False |])
#else
True -- No explicit kind variable binders prior to GHC 8.0
#endif
test_t112 :: [Bool]
test_t112 =
$(do a <- newName "a"
b <- newName "b"
let aVar = DVarT a
bVar = DVarT b
aTvb = DPlainTV a ()
bTvb = DPlainTV b ()
fvsABExpected = [aTvb, bTvb]
fvsABActual = toposortTyVarsOf [aVar, bVar]
fvsBAExpected = [bTvb, aTvb]
fvsBAActual = toposortTyVarsOf [bVar, aVar]
eqAB = fvsABExpected `eqTH` fvsABActual
eqBA = fvsBAExpected `eqTH` fvsBAActual
[| [eqAB, eqBA] |])
test_t132 :: Bool
test_t132 =
$(do let c = mkName "C"
m = mkName "m"
a = mkName "a"
fixity = Fixity 5 InfixR
-- Defines a class with a fixity declaration inside, i.e.,
--
-- class C a where
-- infixr 5 `m`
-- m :: a
--
-- We define this by hand to avoid GHC#17608 on pre-9.0 GHCs.
decs = sweeten [ DClassD [] c [DPlainTV a ()] []
[ DLetDec (DInfixD fixity m)
, DLetDec (DSigD m (DVarT a))
]
]
expected = Just fixity
actual <- withLocalDeclarations decs (reifyFixityWithLocals m)
expected `eqTHSplice` actual)
test_t154 :: Bool
test_t154 =
#if __GLASGOW_HASKELL__ >= 800
$(do decs <- [d| data T where
(:$$:) :: Int -> Int -> T
|]
ddecs <- dsDecs decs
let mb_is_infix = case ddecs of
[DDataD _ _ _ _ _ [DCon _ _ _ (DNormalC is_infix _) _] _]
-> Just is_infix
_ -> Nothing
mb_is_infix `eqTHSplice` Just False)
#else
True -- GadtC didn't exist prior to GHC 8.0, so the quote above will
-- normalize to `data T = (:$$:) Int Int`. This defeats the point of
-- this test, so let's just not bother testing this on pre-8.0 GHCs.
#endif
-- Unit tests for functions that compute free variables (e.g., fvDType)
test_fvs :: [Bool]
test_fvs =
$(do a <- newName "a"
let -- (Show a => Show (Maybe a)) => String
ty1 = DConstrainedT
[DConstrainedT [DConT ''Show `DAppT` DVarT a]
(DConT ''Show `DAppT` (DConT ''Maybe `DAppT` DVarT a))]
(DConT ''String)
b1 = fvDType ty1 `eqTH` OS.singleton a -- #93
[| [b1] |])
test_kind_substitution :: [Bool]
test_kind_substitution =
$(do a <- newName "a"
b <- newName "b"
c <- newName "c"
k <- newName "k"
let subst = M.singleton a (DVarT b)
-- (Nothing :: Maybe a)
ty1 = DSigT (DConT 'Nothing) (DConT ''Maybe `DAppT` DVarT a)
-- forall (c :: a). c
ty2 = DForallT (DForallInvis [DKindedTV c SpecifiedSpec (DVarT a)])
(DVarT c)
-- forall a (c :: a). c
ty3 = DForallT (DForallInvis [ DPlainTV a SpecifiedSpec
, DKindedTV c SpecifiedSpec (DVarT a)
])
(DVarT c)
-- forall (a :: k) k (b :: k). Proxy b -> Proxy a
ty4 = DForallT (DForallInvis
[ DKindedTV a SpecifiedSpec (DVarT k)
, DPlainTV k SpecifiedSpec
, DKindedTV b SpecifiedSpec (DVarT k)
])
(DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT b)
`DAppT` (DConT ''Proxy `DAppT` DVarT a))
substTy1 <- substTy subst ty1
substTy2 <- substTy subst ty2
substTy3 <- substTy subst ty3
substTy4 <- substTy subst ty4
let freeVars1 = fvDType substTy1
freeVars2 = fvDType substTy2
freeVars3 = fvDType substTy3
freeVars4 = fvDType substTy4
b1 = freeVars1 `eqTH` OS.singleton b
b2 = freeVars2 `eqTH` OS.singleton b
b3 = freeVars3 `eqTH` OS.empty
b4 = freeVars4 `eqTH` OS.singleton k
[| [b1, b2, b3, b4] |])
test_lookup_value_type_names :: [Bool]
test_lookup_value_type_names =
$(do let nameStr = "***"
valName <- newName nameStr
typeName <- newName nameStr
let tyDec = DTySynD typeName [] (DConT ''Bool)
decs = decsToTH [ DLetDec (DSigD valName (DConT ''Bool))
, DLetDec (DValD (DVarP valName) (DConE 'False))
, tyDec ]
lookupReify lookup_fun = withLocalDeclarations decs $ do
Just n <- lookup_fun nameStr
Just i <- dsReify n
return i
reifiedVal <- lookupReify lookupValueNameWithLocals
reifiedType <- lookupReify lookupTypeNameWithLocals
let b1 = reifiedVal `eqTH` DVarI valName (DConT ''Bool) Nothing
let b2 = reifiedType `eqTH` DTyConI tyDec Nothing
[| [b1, b2] |])
local_reifications :: [String]
local_reifications = $(do decs <- reifyDecs
m_infos <- withLocalDeclarations decs $
mapM reifyWithLocals_maybe reifyDecsNames
let m_infos' = assumeStarT m_infos
ListE <$> mapM (Syn.lift . show) (unqualify m_infos'))
type T123G = Either () ()
type T123F = Either T123G T123G
type T123E = Either T123F T123F
type T123D = Either T123E T123E
type T123C = Either T123D T123D
type T123B = Either T123C T123C
type T123A = Either T123B T123B
$reifyDecs
$(return []) -- somehow, this is necessary to get the staging correct for the
-- reifications below. Weird.
normal_reifications :: [String]
normal_reifications = $(do infos <- mapM reify reifyDecsNames
ListE <$> mapM (Syn.lift . show . Just)
(dropTrailing0s $ delinearize $ unqualify infos))
zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M f (a:as) (b:bs) (c:cs) = liftM2 (:) (f a b c) (zipWith3M f as bs cs)
zipWith3M _ _ _ _ = return []
simplCase :: [Bool]
simplCase = $( do exps <- sequence simplCaseTests
dexps <- mapM dsExp exps
sexps <- mapM scExp dexps
bools <- zipWithM (\e1 e2 -> [| $(return e1) == $(return e2) |])
exps (map sweeten sexps)
return $ ListE bools )
test_roundtrip :: [Bool]
test_roundtrip = $( do exprs <- sequence test_exprs
ds_exprs1 <- mapM dsExp exprs
let th_exprs1 = map expToTH ds_exprs1
ds_exprs2 <- mapM dsExp th_exprs1
let th_exprs2 = map expToTH ds_exprs2
ds_exprs3 <- mapM dsExp th_exprs2
let bools = zipWith eqTH ds_exprs2 ds_exprs3
Syn.lift bools )
test_matchTy :: [Bool]
test_matchTy =
[ matchTy NoIgnore (DVarT a) (DConT ''Bool) == Just (M.singleton a (DConT ''Bool))
, matchTy NoIgnore (DVarT a) (DVarT a) == Just (M.singleton a (DVarT a))
, matchTy NoIgnore (DVarT a) (DVarT b) == Just (M.singleton a (DVarT b))
, matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT b)
(DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool)
== Just (M.fromList [(a, DConT ''Int), (b, DConT ''Bool)])
, matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a)
(DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Int)
== Just (M.singleton a (DConT ''Int))
, matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a)
(DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool)
== Nothing
, matchTy NoIgnore (DConT ''Int) (DConT ''Bool) == Nothing
, matchTy NoIgnore (DConT ''Int) (DConT ''Int) == Just M.empty
, matchTy NoIgnore (DConT ''Int) (DVarT a) == Nothing
, matchTy NoIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) == Nothing
, matchTy YesIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int)
== Just (M.singleton a (DConT ''Int))
]
where
a = mkName "a"
b = mkName "b"
-- Test that type synonym expansion is efficient
test_t123 :: ()
test_t123 =
$(do _ <- expand (DConT ''T123A)
[| () |])
main :: IO ()
main = hspec $ do
describe "th-desugar library" $ do
it "compiles" $ True
it "expands" $ test_expand
zipWithM (\num success -> it ("passes dec test " ++ show num) success)
dec_test_nums test_dec
-- instance test 1 is part of dectest 6.
it "passes instance test" $ $(do ty <- [t| Int -> Bool |]
[inst1, inst2] <- reifyInstances ''Show [ty]
inst1 `eqTHSplice` inst2)
it "makes type names" $ test_mkName
it "fixes bug 8884" $ test_bug8884
it "flattens DValDs" $ flatten_dvald
it "extracts record selectors" $ test_rec_sels
it "works with standalone deriving" $ test_standalone_deriving
it "works with deriving strategies" $ test_deriving_strategies
it "doesn't expand local type families" $ test_local_tyfam_expansion
it "doesn't crash on a stuck type family application" $ test_stuck_tyfam_expansion
it "expands type synonyms in kinds" $ test_t85
it "toposorts free variables in polytypes" $ test_t92
it "expands type synonyms in type variable binders" $ test_t97
it "reifies GADT record selectors correctly" $ test_t100
zipWithM (\b n -> it ("collects GADT record selectors correctly" ++ show n) b)
test_t102 [1..]
it "quantifies kind variables in desugared ADT constructors" $ test_t103
it "reifies data type return kinds accurately" $ test_getDataD_kind_sig
zipWithM (\b n -> it ("toposorts free variables deterministically " ++ show n) b)
test_t112 [1..]
it "reifies fixity declarations inside of classes" $ test_t132
zipWithM (\b n -> it ("computes free variables correctly " ++ show n) b)
test_fvs [1..]
it "desugars non-infix GADT constructors with symbolic names correctly" $ test_t154
-- Remove map pprints here after switch to th-orphans
zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t')
$(sequence round_trip_types >>= Syn.lift . map pprint)
$(sequence round_trip_types >>=
mapM (\ t -> withLocalDeclarations [] (dsType t >>= expandType >>= return . typeToTH)) >>=
Syn.lift . map pprint)
zipWith3M (\a b n -> it ("reifies local definition " ++ show n) $ a == b)
local_reifications normal_reifications [1..]
zipWithM (\b n -> it ("works on simplCase test " ++ show n) b) simplCase [1..]
zipWithM (\b n -> it ("round-trip successfully on case " ++ show n) b) test_roundtrip [1..]
zipWithM (\b n -> it ("lookups up local value and type names " ++ show n) b)
test_lookup_value_type_names [1..]
zipWithM (\b n -> it ("substitutes tyvar binder kinds " ++ show n) b)
test_kind_substitution [1..]
zipWithM (\b n -> it ("matches types " ++ show n) b)
test_matchTy [1..]
zipWithM (\b n -> it ("reifies kinds of declarations with CUSKs " ++ show n) b)
test_reify_type_cusks [1..]
zipWithM (\b n -> it ("reifies kinds of declarations without CUSKs " ++ show n) b)
test_reify_type_no_cusks [1..]
zipWithM (\b n -> it ("reifies the kinds of declarations with signatures " ++ show n) b)
test_reify_kind_sigs [1..]
fromHUnitTest tests