Add LANGUAGE pragmas to compiler/ source files
[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, patSynArgTys, patSynTyDetails,
17         patSynWrapper, patSynMatcher,
18         patSynExTyVars, patSynSig, patSynInstArgTys
19     ) where
20
21 #include "HsVersions.h"
22
23 import Type
24 import Name
25 import Outputable
26 import Unique
27 import Util
28 import BasicTypes
29 import FastString
30 import Var
31 import Id
32 import TcType
33 import HsBinds( HsPatSynDetails(..) )
34
35 import qualified Data.Data as Data
36 import qualified Data.Typeable
37 import Data.Function
38 \end{code}
39
40
41 Pattern synonym representation
42 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
43 Consider the following pattern synonym declaration
44
45         pattern P x = MkT [x] (Just 42)
46
47 where
48         data T a where
49               MkT :: (Show a, Ord b) => [b] -> a -> T a
50
51 so pattern P has type
52
53         b -> T (Maybe t)
54
55 with the following typeclass constraints:
56
57         provides: (Show (Maybe t), Ord b)
58         requires: (Eq t, Num t)
59
60 In this case, the fields of MkPatSyn will be set as follows:
61
62   psArgs       = [x :: b]
63   psArity      = 1
64   psInfix      = False
65
66   psUnivTyVars = [t]
67   psExTyVars   = [b]
68   psTheta      = ((Show (Maybe t), Ord b), (Eq t, Num t))
69   psOrigResTy  = T (Maybe t)
70
71
72 %************************************************************************
73 %*                                                                      *
74 \subsection{Pattern synonyms}
75 %*                                                                      *
76 %************************************************************************
77
78 \begin{code}
79 -- | A pattern synonym
80 data PatSyn
81   = MkPatSyn {
82         psId          :: Id,
83         psUnique      :: Unique,                 -- Cached from Name
84         psMatcher     :: Id,
85         psWrapper     :: Maybe Id,
86
87         psArgs        :: [Var],
88         psArity       :: Arity,                  -- == length psArgs
89         psInfix       :: Bool,                   -- True <=> declared infix
90
91         psUnivTyVars  :: [TyVar],                -- Universially-quantified type variables
92         psExTyVars    :: [TyVar],                -- Existentially-quantified type vars
93         psTheta       :: (ThetaType, ThetaType), -- Provided and required dictionaries
94         psOrigResTy   :: Type
95   }
96   deriving Data.Typeable.Typeable
97 \end{code}
98
99 %************************************************************************
100 %*                                                                      *
101 \subsection{Instances}
102 %*                                                                      *
103 %************************************************************************
104
105 \begin{code}
106 instance Eq PatSyn where
107     (==) = (==) `on` getUnique
108     (/=) = (/=) `on` getUnique
109
110 instance Ord PatSyn where
111     (<=) = (<=) `on` getUnique
112     (<) = (<) `on` getUnique
113     (>=) = (>=) `on` getUnique
114     (>) = (>) `on` getUnique
115     compare = compare `on` getUnique
116
117 instance Uniquable PatSyn where
118     getUnique = psUnique
119
120 instance NamedThing PatSyn where
121     getName = getName . psId
122
123 instance Outputable PatSyn where
124     ppr = ppr . getName
125
126 instance OutputableBndr PatSyn where
127     pprInfixOcc = pprInfixName . getName
128     pprPrefixOcc = pprPrefixName . getName
129
130 instance Data.Data PatSyn where
131     -- don't traverse?
132     toConstr _   = abstractConstr "PatSyn"
133     gunfold _ _  = error "gunfold"
134     dataTypeOf _ = mkNoRepType "PatSyn"
135 \end{code}
136
137
138 %************************************************************************
139 %*                                                                      *
140 \subsection{Construction}
141 %*                                                                      *
142 %************************************************************************
143
144 \begin{code}
145 -- | Build a new pattern synonym
146 mkPatSyn :: Name
147          -> Bool       -- ^ Is the pattern synonym declared infix?
148          -> [Var]      -- ^ Original arguments
149          -> [TyVar]    -- ^ Universially-quantified type variables
150          -> [TyVar]    -- ^ Existentially-quantified type variables
151          -> ThetaType  -- ^ Wanted dicts
152          -> ThetaType  -- ^ Given dicts
153          -> Type       -- ^ Original result type
154          -> Id         -- ^ Name of matcher
155          -> Maybe Id   -- ^ Name of wrapper
156          -> PatSyn
157 mkPatSyn name declared_infix orig_args
158          univ_tvs ex_tvs
159          prov_theta req_theta
160          orig_res_ty
161          matcher wrapper
162     = MkPatSyn {psId = id, psUnique = getUnique name,
163                 psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
164                 psTheta = (prov_theta, req_theta),
165                 psInfix = declared_infix,
166                 psArgs = orig_args,
167                 psArity = length orig_args,
168                 psOrigResTy = orig_res_ty,
169                 psMatcher = matcher,
170                 psWrapper = wrapper }
171   where
172     pat_ty = mkSigmaTy univ_tvs req_theta $
173              mkSigmaTy ex_tvs prov_theta $
174              mkFunTys (map varType orig_args) orig_res_ty
175     id = mkLocalId name pat_ty
176 \end{code}
177
178 \begin{code}
179 -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
180 patSynId :: PatSyn -> Id
181 patSynId = psId
182
183 patSynType :: PatSyn -> Type
184 patSynType = psOrigResTy
185
186 -- | Should the 'PatSyn' be presented infix?
187 patSynIsInfix :: PatSyn -> Bool
188 patSynIsInfix = psInfix
189
190 -- | Arity of the pattern synonym
191 patSynArity :: PatSyn -> Arity
192 patSynArity = psArity
193
194 patSynArgs :: PatSyn -> [Var]
195 patSynArgs = psArgs
196
197 patSynArgTys :: PatSyn -> [Type]
198 patSynArgTys = map varType . patSynArgs
199
200 patSynTyDetails :: PatSyn -> HsPatSynDetails Type
201 patSynTyDetails ps = case (patSynIsInfix ps, patSynArgTys ps) of
202     (True, [left, right]) -> InfixPatSyn left right
203     (_, tys) -> PrefixPatSyn tys
204
205 patSynExTyVars :: PatSyn -> [TyVar]
206 patSynExTyVars = psExTyVars
207
208 patSynSig :: PatSyn -> ([TyVar], [TyVar], (ThetaType, ThetaType))
209 patSynSig ps = (psUnivTyVars ps, psExTyVars ps, psTheta ps)
210
211 patSynWrapper :: PatSyn -> Maybe Id
212 patSynWrapper = psWrapper
213
214 patSynMatcher :: PatSyn -> Id
215 patSynMatcher = psMatcher
216
217 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
218 patSynInstArgTys ps inst_tys
219   = ASSERT2( length tyvars == length inst_tys
220           , ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
221     map (substTyWith tyvars inst_tys) arg_tys
222   where
223     (univ_tvs, ex_tvs, _) = patSynSig ps
224     arg_tys = map varType (psArgs ps)
225     tyvars = univ_tvs ++ ex_tvs
226 \end{code}