1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, ScopedTypeVariables, TypeOperators, ConstraintKinds, DataKinds, PolyKinds #-}
#if __GLASGOW_HASKELL__ < 806
{-# Language TypeInType #-}
#endif
#if __GLASGOW_HASKELL__ >= 810
{-# Language StandaloneKindSignatures #-}
{-# Language TypeApplications #-}
{-# Language UnliftedNewtypes #-}
#endif
#if MIN_VERSION_template_haskell(2,20,0)
{-# Language TypeData #-}
#endif
{-|
Module : Types
Description : Test cases for the th-abstraction package
Copyright : Eric Mertens 2017
License : ISC
Maintainer : emertens@gmail.com
This module defined types used for testing features of @th-abstraction@
on various versions of GHC.
-}
module Types where
import Data.Kind
import GHC.Exts (Constraint)
import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Lib (starK)
#if __GLASGOW_HASKELL__ >= 810
import GHC.Exts (Any, TYPE)
#endif
type Gadt1Int = Gadt1 Int
infixr 6 :**:
data Gadt1 (a :: *) where
Gadtc1 :: Int -> Gadt1Int
Gadtc2 :: (a,a) -> Gadt1 a
(:**:) :: Bool -> Char -> Gadt1 () -- This is declared infix
(:!!:) :: Char -> Bool -> Gadt1 Double -- This is not
data Adt1 (a :: *) (b :: *) = Adtc1 (a,b) | Bool `Adtc2` Int
data Gadtrec1 a where
Gadtrecc1, Gadtrecc2 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b)
data Equal :: * -> * -> * -> * where
Equalc :: (Read a, Show a) => [a] -> Maybe a -> Equal a a a
data Showable :: * where
Showable :: Show a => a -> Showable
data R = R1 { field1, field2 :: Int }
data Gadt2 :: * -> * -> * where
Gadt2c1 :: Gadt2 a [a]
Gadt2c2 :: Gadt2 [a] a
Gadt2c3 :: Gadt2 [a] [a]
data VoidStoS (f :: * -> *)
data StrictDemo = StrictDemo Int !Int {-# UNPACK #-} !Int
type (:+:) = Either
data MyPair a b = a :^: b
-- Data families
data family T43Fam
type Id (a :: *) = a
data family DF (a :: *)
data instance DF (Maybe a) = DFMaybe Int [a]
data family DF1 (a :: k)
data instance DF1 (b :: *) = DF1 b
data family Quoted (a :: *)
data family Poly (a :: k)
data instance Poly a = MkPoly
data family GadtFam (a :: *) (b :: *)
data instance GadtFam c d where
MkGadtFam1 :: x -> y -> GadtFam y x
(:&&:) :: e -> f -> GadtFam [e] f -- This is declard infix
(:^^:) :: Int -> Int -> GadtFam Int Int -- This is not
(:#%:) :: { famRec1, famRec2 :: Bool } -> GadtFam Bool Bool -- Nor is this
MkGadtFam4 :: (Int ~ z) => z -> GadtFam z z
MkGadtFam5 :: (q ~ Char) => q -> GadtFam Bool Bool
infixl 3 :&&:, :#%:
data family FamLocalDec1 a
data family FamLocalDec2 a b c
data family T46 a b c
data instance T46 (f (p :: *)) (f p) q = MkT46 q
data family T73 a b
data instance T73 Int b = MkT73 b
data family T95 :: * -> *
data instance T95 [a] = MkT95 a
type Konst (a :: Constraint) (b :: Constraint) = a
type PredSyn1 a b = Konst (Show a) (Read b)
type PredSyn2 a b = Konst (PredSyn1 a b) (Show a)
type PredSyn3 c = Int ~ c
data PredSynT =
PredSyn1 Int Int => MkPredSynT1 Int
| PredSyn2 Int Int => MkPredSynT2 Int
| PredSyn3 Int => MkPredSynT3 Int
data T37a (k :: Type) :: k -> Type where
MkT37a :: T37a Bool a
#if __GLASGOW_HASKELL__ >= 810
type T37b :: k -> Type
#endif
data T37b (a :: k) where
MkT37b :: forall (a :: Bool). T37b a
#if __GLASGOW_HASKELL__ >= 810
type T37c :: k -> Type
#endif
data T37c (a :: k) where
MkT37c :: T37c Bool
data Prox (a :: k) = Prox
data T48 :: Type -> Type where
MkT48 :: forall a (x :: a). Prox x -> T48 a
data T75 (k :: Type) where
MkT75 :: forall k (a :: k). Prox a -> T75 k
#if MIN_VERSION_template_haskell(2,20,0)
type data T100 = MkT100
#endif
#if __GLASGOW_HASKELL__ >= 810
type T107 :: TYPE r
newtype T107 where
MkT107 :: forall r. Any @(TYPE r) -> T107 @r
#endif
-- We must define these here due to Template Haskell staging restrictions
justCI :: ConstructorInfo
justCI =
ConstructorInfo
{ constructorName = 'Just
, constructorVars = []
, constructorContext = []
, constructorFields = [VarT (mkName "a")]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor
}
gadtRecVanillaCI :: ConstructorInfo
gadtRecVanillaCI =
ConstructorInfo
{ constructorName = 'Gadtrecc1
, constructorVars = [v1K, v2K]
, constructorContext =
[equalPred a (AppT (AppT (TupleT 2) (VarT v1)) (VarT v2))]
, constructorFields = [VarT v1, VarT v2]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = RecordConstructor ['gadtrec1a, 'gadtrec1b] }
where
a = VarT (mkName "a")
names@[v1,v2] = map mkName ["v1","v2"]
[v1K,v2K] = map (\n -> kindedTV n starK) names
gadtRecFamCI :: ConstructorInfo
gadtRecFamCI =
ConstructorInfo
{ constructorName = '(:#%:)
, constructorVars = []
, constructorContext = [ equalPred cTy (ConT ''Bool)
, equalPred dTy (ConT ''Bool)
]
, constructorFields = [ConT ''Bool, ConT ''Bool]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = RecordConstructor ['famRec1, 'famRec2] }
where
[cTy,dTy] = map (VarT . mkName) ["c", "d"]
|
