[project @ 2000-09-22 15:56:12 by simonpj]
[ghc-hetmet.git] / ghc / compiler / parser / ParseUtil.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1999
3 %
4 \section[ParseUtil]{Parser Utilities}
5
6 \begin{code}
7 module ParseUtil (
8           parseError            -- String -> Pa
9         , cbot                  -- a
10         , splitForConApp        -- RdrNameHsType -> [RdrNameBangType]
11                                 --     -> P (RdrName, [RdrNameBangType])
12
13         , mkRecConstrOrUpdate   -- HsExp -> [HsFieldUpdate] -> P HsExp
14         , groupBindings
15         
16         , mkExtName             -- Maybe ExtName -> RdrName -> ExtName
17
18         , checkPrec             -- String -> P String
19         , checkContext          -- HsType -> P HsContext
20         , checkInstType         -- HsType -> P HsType
21         , checkDataHeader       -- HsQualType -> P (HsContext,HsName,[HsName])
22         , checkSimple           -- HsType -> [HsName] -> P ((HsName,[HsName]))
23         , checkPattern          -- HsExp -> P HsPat
24         , checkPatterns         -- [HsExp] -> P [HsPat]
25         -- , checkExpr          -- HsExp -> P HsExp
26         , checkValDef           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
27         , checkValSig           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
28  ) where
29
30 #include "HsVersions.h"
31
32 import Lex
33 import HsSyn            -- Lots of it
34 import SrcLoc
35 import RdrHsSyn         ( mkNPlusKPatIn, unitTyCon_RDR,
36                           RdrBinding(..),
37                           RdrNameHsType, RdrNameBangType, RdrNameContext,
38                           RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
39                           RdrNameHsRecordBinds, RdrNameMonoBinds
40                         )
41 import RdrName
42 import CallConv
43 import OccName          ( dataName, varName, tcClsName,
44                           occNameSpace, setOccNameSpace, occNameUserString )
45 import FastString       ( unpackFS )
46 import UniqFM           ( UniqFM, listToUFM, lookupUFM )
47 import Outputable
48
49 -----------------------------------------------------------------------------
50 -- Misc utils
51
52 parseError :: String -> P a
53 parseError s = 
54   getSrcLocP `thenP` \ loc ->
55   failMsgP (hcat [ppr loc, text ": ", text s])
56
57 cbot = panic "CCall:result_ty"
58
59 -----------------------------------------------------------------------------
60 -- splitForConApp
61
62 -- When parsing data declarations, we sometimes inadvertently parse
63 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
64 -- This function splits up the type application, adds any pending
65 -- arguments, and converts the type constructor back into a data constructor.
66
67 splitForConApp :: RdrNameHsType -> [RdrNameBangType]
68         -> P (RdrName, [RdrNameBangType])
69
70 splitForConApp  t ts = split t ts
71  where
72         split (HsAppTy t u) ts = split t (Unbanged u : ts)
73
74         split (HsTyVar t)   ts  = 
75                 -- check that we've got a type constructor at the head
76            if occNameSpace t_occ /= tcClsName
77                 then parseError 
78                         (showSDoc (text "not a constructor: `" <> 
79                                         ppr t <> char '\''))
80                 else returnP (con, ts)
81            where t_occ = rdrNameOcc t
82                  con   = setRdrNameOcc t (setOccNameSpace t_occ dataName)
83
84         split _ _ = parseError "Illegal data/newtype declaration"
85
86 ----------------------------------------------------------------------------
87 -- Various Syntactic Checks
88
89 callConvFM :: UniqFM CallConv
90 callConvFM = listToUFM $
91       map (\ (x,y) -> (_PK_ x,y))
92      [  ("stdcall",  stdCallConv),
93         ("ccall",    cCallConv)
94 --      ("pascal",   pascalCallConv),
95 --      ("fastcall", fastCallConv)
96      ]
97
98 checkCallConv :: FAST_STRING -> P CallConv
99 checkCallConv s = 
100   case lookupUFM callConvFM s of
101         Nothing -> parseError ("unknown calling convention: `"
102                                  ++ unpackFS s ++ "'")
103         Just conv -> returnP conv
104
105 checkInstType :: RdrNameHsType -> P RdrNameHsType
106 checkInstType t 
107   = case t of
108         HsForAllTy tvs ctxt ty ->
109                 checkDictTy ty [] `thenP` \ dict_ty ->
110                 returnP (HsForAllTy tvs ctxt dict_ty)
111
112         ty ->   checkDictTy ty [] `thenP` \ dict_ty->
113                 returnP (HsForAllTy Nothing [] dict_ty)
114
115 checkContext :: RdrNameHsType -> P RdrNameContext
116 checkContext (HsTupleTy _ ts) 
117   = mapP (\t -> checkPred t []) ts `thenP` \ps ->
118     returnP ps
119 checkContext (HsTyVar t) -- empty contexts are allowed
120   | t == unitTyCon_RDR = returnP []
121 checkContext t 
122   = checkPred t [] `thenP` \p ->
123     returnP [p]
124
125 checkPred :: RdrNameHsType -> [RdrNameHsType] 
126         -> P (HsPred RdrName)
127 checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
128         = returnP (HsPClass t args)
129 checkPred (HsAppTy l r) args = checkPred l (r:args)
130 checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty)
131 checkPred _ _ = parseError "Illegal class assertion"
132
133 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
134 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
135         = returnP (mkHsDictTy t args)
136 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
137 checkDictTy _ _ = parseError "Illegal class assertion"
138
139 checkDataHeader :: RdrNameHsType 
140         -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
141 checkDataHeader (HsForAllTy Nothing cs t) =
142    checkSimple t []          `thenP` \(c,ts) ->
143    returnP (cs,c,map UserTyVar ts)
144 checkDataHeader t =
145    checkSimple t []          `thenP` \(c,ts) ->
146    returnP ([],c,map UserTyVar ts)
147
148 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
149 checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a 
150    = checkSimple l (a:xs)
151 checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
152 checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
153
154 ---------------------------------------------------------------------------
155 -- Checking Patterns.
156
157 -- We parse patterns as expressions and check for valid patterns below,
158 -- nverting the expression into a pattern at the same time.
159
160 checkPattern :: RdrNameHsExpr -> P RdrNamePat
161 checkPattern e = checkPat e []
162
163 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
164 checkPatterns es = mapP checkPattern es
165
166 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
167 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
168 checkPat (HsApp f x) args = 
169         checkPat x [] `thenP` \x ->
170         checkPat f (x:args)
171 checkPat e [] = case e of
172         EWildPat           -> returnP WildPatIn
173         HsVar x            -> returnP (VarPatIn x)
174         HsLit l            -> returnP (LitPatIn l)
175         HsOverLit l        -> returnP (NPatIn l)
176         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPatIn)
177         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPatIn n)
178         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
179                               -- Pattern signatures are parsed as sigtypes,
180                               -- but they aren't explicit forall points.  Hence
181                               -- we have to remove the implicit forall here.
182                               let t' = case t of 
183                                           HsForAllTy Nothing [] ty -> ty
184                                           other -> other
185                               in
186                               returnP (SigPatIn e t')
187
188         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _)) 
189                            | plus == plus_RDR
190                            -> returnP (mkNPlusKPatIn n lit)
191
192         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
193                               checkPat r [] `thenP` \r ->
194                               case op of
195                                  HsVar c -> returnP (ConOpPatIn l c fix r)
196                                  _ -> patFail
197
198         HsPar e            -> checkPat e [] `thenP` (returnP . ParPatIn)
199         ExplicitList es    -> mapP (\e -> checkPat e []) es `thenP` \ps ->
200                               returnP (ListPatIn ps)
201         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
202                               returnP (TuplePatIn ps b)
203         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
204                               returnP (RecPatIn c fs)
205         _ -> patFail
206
207 checkPat _ _ = patFail
208
209 checkPatField :: (RdrName, RdrNameHsExpr, Bool) 
210         -> P (RdrName, RdrNamePat, Bool)
211 checkPatField (n,e,b) =
212         checkPat e [] `thenP` \p ->
213         returnP (n,p,b)
214
215 patFail = parseError "Parse error in pattern"
216
217
218 ---------------------------------------------------------------------------
219 -- Check Equation Syntax
220
221 checkValDef 
222         :: RdrNameHsExpr
223         -> Maybe RdrNameHsType
224         -> RdrNameGRHSs
225         -> SrcLoc
226         -> P RdrBinding
227
228 checkValDef lhs opt_sig grhss loc
229  = case isFunLhs lhs [] of
230            Just (f,inf,es) -> 
231                 checkPatterns es `thenP` \ps ->
232                 returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
233
234            Nothing ->
235                 checkPattern lhs `thenP` \lhs ->
236                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
237
238 checkValSig
239         :: RdrNameHsExpr
240         -> RdrNameHsType
241         -> SrcLoc
242         -> P RdrBinding
243 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
244 checkValSig other     ty loc = parseError "Type signature given for an expression"
245
246
247 -- A variable binding is parsed as an RdrNameFunMonoBind.
248 -- See comments with HsBinds.MonoBinds
249
250 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
251                                 = Just (op, True, (l:r:es))
252 isFunLhs (HsVar f) es | not (isRdrDataCon f)
253                                 = Just (f,False,es)
254 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
255 isFunLhs (HsPar e)   es         = isFunLhs e es
256 isFunLhs _ _                    = Nothing
257
258 ---------------------------------------------------------------------------
259 -- Miscellaneous utilities
260
261 checkPrec :: Integer -> P ()
262 checkPrec i | 0 <= i && i <= 9 = returnP ()
263             | otherwise        = parseError "precedence out of range"
264
265 mkRecConstrOrUpdate 
266         :: RdrNameHsExpr 
267         -> RdrNameHsRecordBinds
268         -> P RdrNameHsExpr
269
270 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
271   = returnP (RecordCon c fs)
272 mkRecConstrOrUpdate exp fs@(_:_) 
273   = returnP (RecordUpd exp fs)
274 mkRecConstrOrUpdate _ _
275   = parseError "Empty record update"
276
277 -- Supplying the ext_name in a foreign decl is optional ; if it
278 -- isn't there, the Haskell name is assumed. Note that no transformation
279 -- of the Haskell name is then performed, so if you foreign export (++),
280 -- it's external name will be "++". Too bad; it's important because we don't
281 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
282 -- (This is why we use occNameUserString.)
283 mkExtName :: Maybe ExtName -> RdrName -> ExtName
284 mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
285                                   Nothing
286 mkExtName (Just x) _    = x
287
288 -----------------------------------------------------------------------------
289 -- group function bindings into equation groups
290
291 -- we assume the bindings are coming in reverse order, so we take the srcloc
292 -- from the *last* binding in the group as the srcloc for the whole group.
293
294 groupBindings :: [RdrBinding] -> RdrBinding
295 groupBindings binds = group Nothing binds
296   where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
297         group (Just bind) [] = RdrValBinding bind
298         group Nothing [] = RdrNullBind
299
300                 -- don't group together FunMonoBinds if they have
301                 -- no arguments.  This is necessary now that variable bindings
302                 -- with no arguments are now treated as FunMonoBinds rather
303                 -- than pattern bindings (tests/rename/should_fail/rnfail002).
304         group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
305                     (RdrValBinding (FunMonoBind f' _ 
306                                         [mtch@(Match _ (_:_) _ _)] loc)
307                         : binds)
308             | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
309
310         group (Just so_far) binds
311             = RdrValBinding so_far `RdrAndBindings` group Nothing binds
312         group Nothing (bind:binds)
313             = case bind of
314                 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
315                 other -> bind `RdrAndBindings` group Nothing binds
316
317 plus_RDR = mkSrcUnqual varName SLIT("+")
318 \end{code}