fe404eb5ed2ea854b589e7b7d154cdcd1107aead
[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         patSynId, patSynType, patSynArity, patSynIsInfix,
16         patSynArgs, patSynTyDetails,
17         patSynWrapper, patSynMatcher,
18         patSynExTyVars, patSynSig, 
19         patSynInstArgTys, patSynInstResTy
20     ) where
21
22 #include "HsVersions.h"
23
24 import Type
25 import Name
26 import Outputable
27 import Unique
28 import Util
29 import BasicTypes
30 import FastString
31 import Var
32 import Id
33 import TcType
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         psId          :: Id,
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 = getName . psId
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 {psId = id, 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   where
222     pat_ty = mkSigmaTy univ_tvs req_theta $
223              mkSigmaTy ex_tvs prov_theta $
224              mkFunTys orig_args orig_res_ty
225     id = mkLocalId name pat_ty
226 \end{code}
227
228 \begin{code}
229 -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
230 patSynId :: PatSyn -> Id
231 patSynId = psId
232
233 patSynType :: PatSyn -> Type
234 patSynType = psOrigResTy
235
236 -- | Should the 'PatSyn' be presented infix?
237 patSynIsInfix :: PatSyn -> Bool
238 patSynIsInfix = psInfix
239
240 -- | Arity of the pattern synonym
241 patSynArity :: PatSyn -> Arity
242 patSynArity = psArity
243
244 patSynArgs :: PatSyn -> [Type]
245 patSynArgs = psArgs
246
247 patSynTyDetails :: PatSyn -> HsPatSynDetails Type
248 patSynTyDetails ps = case (patSynIsInfix ps, patSynArgs ps) of
249     (True, [left, right]) -> InfixPatSyn left right
250     (_, tys) -> PrefixPatSyn tys
251
252 patSynExTyVars :: PatSyn -> [TyVar]
253 patSynExTyVars = psExTyVars
254
255 patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType)
256 patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
257                     , psProvTheta = prov, psReqTheta = req })
258   = (univ_tvs, ex_tvs, prov, req)
259
260 patSynWrapper :: PatSyn -> Maybe Id
261 patSynWrapper = psWrapper
262
263 patSynMatcher :: PatSyn -> Id
264 patSynMatcher = psMatcher
265
266 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
267 -- Return the types of the argument patterns
268 -- e.g.  data D a = forall b. MkD a b (b->a)
269 --       pattern P f x y = MkD (x,True) y f
270 --          D :: forall a. forall b. a -> b -> (b->a) -> D a
271 --          P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
272 --   patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
273 -- NB: the inst_tys should be both universal and existential
274 patSynInstArgTys ps inst_tys
275   = ASSERT2( length tyvars == length inst_tys
276           , ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
277     map (substTyWith tyvars inst_tys) (psArgs ps)
278   where
279     (univ_tvs, ex_tvs, _, _) = patSynSig ps
280     tyvars = univ_tvs ++ ex_tvs
281
282 patSynInstResTy :: PatSyn -> [Type] -> Type
283 -- Return the type of whole pattern
284 -- E.g.  pattern P x y = Just (x,x,y)
285 --         P :: a -> b -> Just (a,a,b)
286 --         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
287 -- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
288 patSynInstResTy ps inst_tys
289   = ASSERT2( length univ_tvs == length inst_tys
290            , ptext (sLit "patSynInstResTy") <+> ppr ps $$ ppr univ_tvs $$ ppr inst_tys )
291     substTyWith univ_tvs inst_tys (psOrigResTy ps)
292   where
293     (univ_tvs, _, _, _) = patSynSig ps
294 \end{code}