Remove dead function patSynTyDetails
[ghc.git] / compiler / basicTypes / PatSyn.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1998
4
5 \section[PatSyn]{@PatSyn@: Pattern synonyms}
6 -}
7
8 {-# LANGUAGE CPP, DeriveDataTypeable #-}
9
10 module PatSyn (
11 -- * Main data types
12 PatSyn, mkPatSyn,
13
14 -- ** Type deconstruction
15 patSynName, patSynArity, patSynIsInfix,
16 patSynArgs, patSynType,
17 patSynMatcher, patSynBuilder,
18 patSynExTyVars, patSynSig,
19 patSynInstArgTys, patSynInstResTy,
20 tidyPatSynIds
21 ) where
22
23 #include "HsVersions.h"
24
25 import Type
26 import TcType( mkSigmaTy )
27 import Name
28 import Outputable
29 import Unique
30 import Util
31 import BasicTypes
32 import FastString
33 import Var
34
35 import qualified Data.Data as Data
36 import qualified Data.Typeable
37 import Data.Function
38
39 {-
40 ************************************************************************
41 * *
42 \subsection{Pattern synonyms}
43 * *
44 ************************************************************************
45 -}
46
47 -- | A pattern synonym
48 -- See Note [Pattern synonym representation]
49 data PatSyn
50 = MkPatSyn {
51 psName :: Name,
52 psUnique :: Unique, -- Cached from Name
53
54 psArgs :: [Type],
55 psArity :: Arity, -- == length psArgs
56 psInfix :: Bool, -- True <=> declared infix
57
58 psUnivTyVars :: [TyVar], -- Universially-quantified type variables
59 psReqTheta :: ThetaType, -- Required dictionaries
60 psExTyVars :: [TyVar], -- Existentially-quantified type vars
61 psProvTheta :: ThetaType, -- Provided dictionaries
62 psOrigResTy :: Type, -- Mentions only psUnivTyVars
63
64 -- See Note [Matchers and builders for pattern synonyms]
65 psMatcher :: (Id, Bool),
66 -- Matcher function.
67 -- If Bool is True then prov_theta and arg_tys are empty
68 -- and type is
69 -- forall (r :: ?) univ_tvs. req_theta
70 -- => res_ty
71 -- -> (forall ex_tvs. Void# -> r)
72 -- -> (Void# -> r)
73 -- -> r
74 --
75 -- Otherwise type is
76 -- forall (r :: ?) univ_tvs. req_theta
77 -- => res_ty
78 -- -> (forall ex_tvs. prov_theta => arg_tys -> r)
79 -- -> (Void# -> r)
80 -- -> r
81
82 psBuilder :: Maybe (Id, Bool)
83 -- Nothing => uni-directional pattern synonym
84 -- Just (builder, is_unlifted) => bi-directional
85 -- Builder function, of type
86 -- forall univ_tvs, ex_tvs. (prov_theta, req_theta)
87 -- => arg_tys -> res_ty
88 -- See Note [Builder for pattern synonyms with unboxed type]
89 }
90 deriving Data.Typeable.Typeable
91
92 {-
93 Note [Pattern synonym representation]
94 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
95 Consider the following pattern synonym declaration
96
97 pattern P x = MkT [x] (Just 42)
98
99 where
100 data T a where
101 MkT :: (Show a, Ord b) => [b] -> a -> T a
102
103 so pattern P has type
104
105 b -> T (Maybe t)
106
107 with the following typeclass constraints:
108
109 provides: (Show (Maybe t), Ord b)
110 requires: (Eq t, Num t)
111
112 In this case, the fields of MkPatSyn will be set as follows:
113
114 psArgs = [b]
115 psArity = 1
116 psInfix = False
117
118 psUnivTyVars = [t]
119 psExTyVars = [b]
120 psProvTheta = (Show (Maybe t), Ord b)
121 psReqTheta = (Eq t, Num t)
122 psOrigResTy = T (Maybe t)
123
124 Note [Matchers and builders for pattern synonyms]
125 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
126 For each pattern synonym P, we generate
127
128 * a "matcher" function, used to desugar uses of P in patterns,
129 which implements pattern matching
130
131 * A "builder" function (for bidirectional pattern synonyms only),
132 used to desugar uses of P in expressions, which constructs P-values.
133
134 For the above example, the matcher function has type:
135
136 $mP :: forall (r :: ?) t. (Eq t, Num t)
137 => T (Maybe t)
138 -> (forall b. (Show (Maybe t), Ord b) => b -> r)
139 -> (Void# -> r)
140 -> r
141
142 with the following implementation:
143
144 $mP @r @t $dEq $dNum scrut cont fail
145 = case scrut of
146 MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
147 _ -> fail Void#
148
149 Notice that the return type 'r' has an open kind, so that it can
150 be instantiated by an unboxed type; for example where we see
151 f (P x) = 3#
152
153 The extra Void# argument for the failure continuation is needed so that
154 it is lazy even when the result type is unboxed.
155
156 For the same reason, if the pattern has no arguments, an extra Void#
157 argument is added to the success continuation as well.
158
159 For *bidirectional* pattern synonyms, we also generate a "builder"
160 function which implements the pattern synonym in an expression
161 context. For our running example, it will be:
162
163 $bP :: forall t b. (Show (Maybe t), Ord b, Eq t, Num t)
164 => b -> T (Maybe t)
165 $bP x = MkT [x] (Just 42)
166
167 NB: the existential/universal and required/provided split does not
168 apply to the builder since you are only putting stuff in, not getting
169 stuff out.
170
171 Injectivity of bidirectional pattern synonyms is checked in
172 tcPatToExpr which walks the pattern and returns its corresponding
173 expression when available.
174
175 Note [Builder for pattern synonyms with unboxed type]
176 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
177 For bidirectional pattern synonyms that have no arguments and have an
178 unboxed type, we add an extra Void# argument to the builder, else it
179 would be a top-level declaration with an unboxed type.
180
181 pattern P = 0#
182
183 $bP :: Void# -> Int#
184 $bP _ = 0#
185
186 This means that when typechecking an occurrence of P in an expression,
187 we must remember that the builder has this void argument. This is
188 done by TcPatSyn.patSynBuilderOcc.
189
190
191 ************************************************************************
192 * *
193 \subsection{Instances}
194 * *
195 ************************************************************************
196 -}
197
198 instance Eq PatSyn where
199 (==) = (==) `on` getUnique
200 (/=) = (/=) `on` getUnique
201
202 instance Ord PatSyn where
203 (<=) = (<=) `on` getUnique
204 (<) = (<) `on` getUnique
205 (>=) = (>=) `on` getUnique
206 (>) = (>) `on` getUnique
207 compare = compare `on` getUnique
208
209 instance Uniquable PatSyn where
210 getUnique = psUnique
211
212 instance NamedThing PatSyn where
213 getName = patSynName
214
215 instance Outputable PatSyn where
216 ppr = ppr . getName
217
218 instance OutputableBndr PatSyn where
219 pprInfixOcc = pprInfixName . getName
220 pprPrefixOcc = pprPrefixName . getName
221
222 instance Data.Data PatSyn where
223 -- don't traverse?
224 toConstr _ = abstractConstr "PatSyn"
225 gunfold _ _ = error "gunfold"
226 dataTypeOf _ = mkNoRepType "PatSyn"
227
228 {-
229 ************************************************************************
230 * *
231 \subsection{Construction}
232 * *
233 ************************************************************************
234 -}
235
236 -- | Build a new pattern synonym
237 mkPatSyn :: Name
238 -> Bool -- ^ Is the pattern synonym declared infix?
239 -> ([TyVar], ThetaType) -- ^ Universially-quantified type variables
240 -- and required dicts
241 -> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables
242 -- and provided dicts
243 -> [Type] -- ^ Original arguments
244 -> Type -- ^ Original result type
245 -> (Id, Bool) -- ^ Name of matcher
246 -> Maybe (Id, Bool) -- ^ Name of builder
247 -> PatSyn
248 mkPatSyn name declared_infix
249 (univ_tvs, req_theta)
250 (ex_tvs, prov_theta)
251 orig_args
252 orig_res_ty
253 matcher builder
254 = MkPatSyn {psName = name, psUnique = getUnique name,
255 psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
256 psProvTheta = prov_theta, psReqTheta = req_theta,
257 psInfix = declared_infix,
258 psArgs = orig_args,
259 psArity = length orig_args,
260 psOrigResTy = orig_res_ty,
261 psMatcher = matcher,
262 psBuilder = builder }
263
264 -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
265 patSynName :: PatSyn -> Name
266 patSynName = psName
267
268 patSynType :: PatSyn -> Type
269 -- The full pattern type, used only in error messages
270 patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
271 , psExTyVars = ex_tvs, psProvTheta = prov_theta
272 , psArgs = orig_args, psOrigResTy = orig_res_ty })
273 = mkSigmaTy univ_tvs req_theta $
274 mkSigmaTy ex_tvs prov_theta $
275 mkFunTys orig_args orig_res_ty
276
277 -- | Should the 'PatSyn' be presented infix?
278 patSynIsInfix :: PatSyn -> Bool
279 patSynIsInfix = psInfix
280
281 -- | Arity of the pattern synonym
282 patSynArity :: PatSyn -> Arity
283 patSynArity = psArity
284
285 patSynArgs :: PatSyn -> [Type]
286 patSynArgs = psArgs
287
288 patSynExTyVars :: PatSyn -> [TyVar]
289 patSynExTyVars = psExTyVars
290
291 patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType, [Type], Type)
292 patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
293 , psProvTheta = prov, psReqTheta = req
294 , psArgs = arg_tys, psOrigResTy = res_ty })
295 = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
296
297 patSynMatcher :: PatSyn -> (Id,Bool)
298 patSynMatcher = psMatcher
299
300 patSynBuilder :: PatSyn -> Maybe (Id, Bool)
301 patSynBuilder = psBuilder
302
303 tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
304 tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
305 = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
306 where
307 tidy_pr (id, dummy) = (tidy_fn id, dummy)
308
309 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
310 -- Return the types of the argument patterns
311 -- e.g. data D a = forall b. MkD a b (b->a)
312 -- pattern P f x y = MkD (x,True) y f
313 -- D :: forall a. forall b. a -> b -> (b->a) -> D a
314 -- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
315 -- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
316 -- NB: the inst_tys should be both universal and existential
317 patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
318 , psExTyVars = ex_tvs, psArgs = arg_tys })
319 inst_tys
320 = ASSERT2( length tyvars == length inst_tys
321 , ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
322 map (substTyWith tyvars inst_tys) arg_tys
323 where
324 tyvars = univ_tvs ++ ex_tvs
325
326 patSynInstResTy :: PatSyn -> [Type] -> Type
327 -- Return the type of whole pattern
328 -- E.g. pattern P x y = Just (x,x,y)
329 -- P :: a -> b -> Just (a,a,b)
330 -- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
331 -- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
332 patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
333 , psOrigResTy = res_ty })
334 inst_tys
335 = ASSERT2( length univ_tvs == length inst_tys
336 , ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
337 substTyWith univ_tvs inst_tys res_ty