Make the matcher and wrapper Ids in PatSyn into LocalIds, not GlobalIds
[ghc.git] / compiler / basicTypes / PatSyn.lhs
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 \begin{code}
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, patSynTyDetails, patSynType,
17         patSynWrapper, patSynMatcher,
18         patSynExTyVars, patSynSig,
19         patSynInstArgTys, patSynInstResTy,
20         tidyPatSynIds, patSynIds
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 import HsBinds( HsPatSynDetails(..) )
35
36 import qualified Data.Data as Data
37 import qualified Data.Typeable
38 import Data.Function
39 \end{code}
40
41
42 Note [Pattern synonym representation]
43 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
44 Consider the following pattern synonym declaration
45
46         pattern P x = MkT [x] (Just 42)
47
48 where
49         data T a where
50               MkT :: (Show a, Ord b) => [b] -> a -> T a
51
52 so pattern P has type
53
54         b -> T (Maybe t)
55
56 with the following typeclass constraints:
57
58         provides: (Show (Maybe t), Ord b)
59         requires: (Eq t, Num t)
60
61 In this case, the fields of MkPatSyn will be set as follows:
62
63   psArgs       = [b]
64   psArity      = 1
65   psInfix      = False
66
67   psUnivTyVars = [t]
68   psExTyVars   = [b]
69   psProvTheta  = (Show (Maybe t), Ord b)
70   psReqTheta   = (Eq t, Num t)
71   psOrigResTy  = T (Maybe t)
72
73 Note [Matchers and wrappers for pattern synonyms]
74 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
75 For each pattern synonym, we generate a single matcher function which
76 implements the actual matching. For the above example, the matcher
77 will have type:
78
79         $mP :: forall r t. (Eq t, Num t)
80             => T (Maybe t)
81             -> (forall b. (Show (Maybe t), Ord b) => b -> r)
82             -> r
83             -> r
84
85 with the following implementation:
86
87         $mP @r @t $dEq $dNum scrut cont fail = case scrut of
88             MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
89             _                                 -> fail
90
91 For *bidirectional* pattern synonyms, we also generate a single wrapper
92 function which implements the pattern synonym in an expression
93 context. For our running example, it will be:
94
95         $WP :: forall t b. (Show (Maybe t), Ord b, Eq t, Num t)
96             => b -> T (Maybe t)
97         $WP x = MkT [x] (Just 42)
98
99 NB: the existential/universal and required/provided split does not
100 apply to the wrapper since you are only putting stuff in, not getting
101 stuff out.
102
103 Injectivity of bidirectional pattern synonyms is checked in
104 tcPatToExpr which walks the pattern and returns its corresponding
105 expression when available.
106
107 %************************************************************************
108 %*                                                                      *
109 \subsection{Pattern synonyms}
110 %*                                                                      *
111 %************************************************************************
112
113 \begin{code}
114 -- | A pattern synonym
115 -- See Note [Pattern synonym representation]
116 data PatSyn
117   = MkPatSyn {
118         psName        :: Name,
119         psUnique      :: Unique,      -- Cached from Name
120
121         psArgs        :: [Type],
122         psArity       :: Arity,       -- == length psArgs
123         psInfix       :: Bool,        -- True <=> declared infix
124
125         psUnivTyVars  :: [TyVar],     -- Universially-quantified type variables
126         psExTyVars    :: [TyVar],     -- Existentially-quantified type vars
127         psProvTheta   :: ThetaType,   -- Provided dictionaries
128         psReqTheta    :: ThetaType,   -- Required dictionaries
129         psOrigResTy   :: Type,        -- Mentions only psUnivTyVars
130
131         -- See Note [Matchers and wrappers for pattern synonyms]
132         psMatcher     :: Id,
133              -- Matcher function, of type
134              --   forall r univ_tvs. req_theta
135              --                   => res_ty
136              --                   -> (forall ex_tvs. prov_theta -> arg_tys -> r)
137              --                   -> r -> r
138
139         psWrapper     :: Maybe Id
140              -- Nothing  => uni-directional pattern synonym
141              -- Just wid => bi-direcitonal
142              -- Wrapper function, of type
143              --  forall univ_tvs, ex_tvs. (prov_theta, req_theta)
144              --                       =>  arg_tys -> res_ty
145   }
146   deriving Data.Typeable.Typeable
147 \end{code}
148
149 %************************************************************************
150 %*                                                                      *
151 \subsection{Instances}
152 %*                                                                      *
153 %************************************************************************
154
155 \begin{code}
156 instance Eq PatSyn where
157     (==) = (==) `on` getUnique
158     (/=) = (/=) `on` getUnique
159
160 instance Ord PatSyn where
161     (<=) = (<=) `on` getUnique
162     (<) = (<) `on` getUnique
163     (>=) = (>=) `on` getUnique
164     (>) = (>) `on` getUnique
165     compare = compare `on` getUnique
166
167 instance Uniquable PatSyn where
168     getUnique = psUnique
169
170 instance NamedThing PatSyn where
171     getName = patSynName
172
173 instance Outputable PatSyn where
174     ppr = ppr . getName
175
176 instance OutputableBndr PatSyn where
177     pprInfixOcc = pprInfixName . getName
178     pprPrefixOcc = pprPrefixName . getName
179
180 instance Data.Data PatSyn where
181     -- don't traverse?
182     toConstr _   = abstractConstr "PatSyn"
183     gunfold _ _  = error "gunfold"
184     dataTypeOf _ = mkNoRepType "PatSyn"
185 \end{code}
186
187
188 %************************************************************************
189 %*                                                                      *
190 \subsection{Construction}
191 %*                                                                      *
192 %************************************************************************
193
194 \begin{code}
195 -- | Build a new pattern synonym
196 mkPatSyn :: Name
197          -> Bool       -- ^ Is the pattern synonym declared infix?
198          -> [Type]     -- ^ Original arguments
199          -> [TyVar]    -- ^ Universially-quantified type variables
200          -> [TyVar]    -- ^ Existentially-quantified type variables
201          -> ThetaType  -- ^ Wanted dicts
202          -> ThetaType  -- ^ Given dicts
203          -> Type       -- ^ Original result type
204          -> Id         -- ^ Name of matcher
205          -> Maybe Id   -- ^ Name of wrapper
206          -> PatSyn
207 mkPatSyn name declared_infix orig_args
208          univ_tvs ex_tvs
209          prov_theta req_theta
210          orig_res_ty
211          matcher wrapper
212     = MkPatSyn {psName = name, psUnique = getUnique name,
213                 psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
214                 psProvTheta = prov_theta, psReqTheta = req_theta,
215                 psInfix = declared_infix,
216                 psArgs = orig_args,
217                 psArity = length orig_args,
218                 psOrigResTy = orig_res_ty,
219                 psMatcher = matcher,
220                 psWrapper = wrapper }
221 \end{code}
222
223 \begin{code}
224 -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
225 patSynName :: PatSyn -> Name
226 patSynName = psName
227
228 patSynType :: PatSyn -> Type
229 -- The full pattern type, used only in error messages
230 patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
231                      , psExTyVars   = ex_tvs,   psProvTheta = prov_theta
232                      , psArgs = orig_args, psOrigResTy = orig_res_ty })
233   = mkSigmaTy univ_tvs req_theta $
234     mkSigmaTy ex_tvs prov_theta $
235     mkFunTys orig_args orig_res_ty
236
237 -- | Should the 'PatSyn' be presented infix?
238 patSynIsInfix :: PatSyn -> Bool
239 patSynIsInfix = psInfix
240
241 -- | Arity of the pattern synonym
242 patSynArity :: PatSyn -> Arity
243 patSynArity = psArity
244
245 patSynArgs :: PatSyn -> [Type]
246 patSynArgs = psArgs
247
248 patSynTyDetails :: PatSyn -> HsPatSynDetails Type
249 patSynTyDetails (MkPatSyn { psInfix = is_infix, psArgs = arg_tys })
250   | is_infix, [left,right] <- arg_tys
251   = InfixPatSyn left right
252   | otherwise
253   = PrefixPatSyn arg_tys
254
255 patSynExTyVars :: PatSyn -> [TyVar]
256 patSynExTyVars = psExTyVars
257
258 patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType, [Type], Type)
259 patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
260                     , psProvTheta = prov, psReqTheta = req
261                     , psArgs = arg_tys, psOrigResTy = res_ty })
262   = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
263
264 patSynWrapper :: PatSyn -> Maybe Id
265 patSynWrapper = psWrapper
266
267 patSynMatcher :: PatSyn -> Id
268 patSynMatcher = psMatcher
269
270 patSynIds :: PatSyn -> [Id]
271 patSynIds (MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
272   = case mb_wrap_id of
273       Nothing      -> [match_id]
274       Just wrap_id -> [match_id, wrap_id]
275
276 tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
277 tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
278   = ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id }
279
280 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
281 -- Return the types of the argument patterns
282 -- e.g.  data D a = forall b. MkD a b (b->a)
283 --       pattern P f x y = MkD (x,True) y f
284 --          D :: forall a. forall b. a -> b -> (b->a) -> D a
285 --          P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
286 --   patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
287 -- NB: the inst_tys should be both universal and existential
288 patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
289                            , psExTyVars = ex_tvs, psArgs = arg_tys })
290                  inst_tys
291   = ASSERT2( length tyvars == length inst_tys
292           , ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
293     map (substTyWith tyvars inst_tys) arg_tys
294   where
295     tyvars = univ_tvs ++ ex_tvs
296
297 patSynInstResTy :: PatSyn -> [Type] -> Type
298 -- Return the type of whole pattern
299 -- E.g.  pattern P x y = Just (x,x,y)
300 --         P :: a -> b -> Just (a,a,b)
301 --         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
302 -- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
303 patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
304                           , psOrigResTy = res_ty })
305                 inst_tys
306   = ASSERT2( length univ_tvs == length inst_tys
307            , ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
308     substTyWith univ_tvs inst_tys res_ty
309 \end{code}