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