[project @ 2000-05-23 11:35:36 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         , checkAssertion        -- HsType -> P HsAsst
22         , checkDataHeader       -- HsQualType -> P (HsContext,HsName,[HsName])
23         , checkSimple           -- HsType -> [HsName] -> P ((HsName,[HsName]))
24         , checkPattern          -- HsExp -> P HsPat
25         , checkPatterns         -- [HsExp] -> P [HsPat]
26         -- , checkExpr          -- HsExp -> P HsExp
27         , checkValDef           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
28         , checkValSig           -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
29
30         
31         -- some built-in names (all :: RdrName)
32         , unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR
33         , tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR
34         , funTyCon_RDR
35
36         -- pseudo-keywords, in var and tyvar forms (all :: RdrName)
37         , as_var_RDR, hiding_var_RDR, qualified_var_RDR, forall_var_RDR
38         , export_var_RDR, label_var_RDR, dynamic_var_RDR, unsafe_var_RDR
39         , stdcall_var_RDR, ccall_var_RDR
40
41         , as_tyvar_RDR, hiding_tyvar_RDR, qualified_tyvar_RDR
42         , export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR
43         , unsafe_tyvar_RDR, stdcall_tyvar_RDR, ccall_tyvar_RDR
44
45         , minus_RDR, pling_RDR, dot_RDR
46
47  ) where
48
49 #include "HsVersions.h"
50
51 import Lex
52 import HsSyn
53 import SrcLoc
54 import RdrHsSyn
55 import RdrName
56 import CallConv
57 import PrelMods         ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
58 import OccName          ( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString )
59 import CmdLineOpts      ( opt_NoImplicitPrelude )
60 import StringBuffer     ( lexemeToString )
61 import FastString       ( unpackFS )
62 import ErrUtils
63 import UniqFM           ( UniqFM, listToUFM, lookupUFM )
64 import Outputable
65
66 -----------------------------------------------------------------------------
67 -- Misc utils
68
69 parseError :: String -> P a
70 parseError s = 
71   getSrcLocP `thenP` \ loc ->
72   failMsgP (hcat [ppr loc, text ": ", text s])
73
74 cbot = panic "CCall:result_ty"
75
76 -----------------------------------------------------------------------------
77 -- splitForConApp
78
79 -- When parsing data declarations, we sometimes inadvertently parse
80 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
81 -- This function splits up the type application, adds any pending
82 -- arguments, and converts the type constructor back into a data constructor.
83
84 splitForConApp :: RdrNameHsType -> [RdrNameBangType]
85         -> P (RdrName, [RdrNameBangType])
86
87 splitForConApp  t ts = split t ts
88  where
89         split (MonoTyApp t u) ts = split t (Unbanged u : ts)
90
91         split (MonoTyVar t)   ts  = returnP (con, ts)
92            where t_occ = rdrNameOcc t
93                  con   = setRdrNameOcc t (setOccNameSpace t_occ dataName)
94
95         split _ _ = parseError "Illegal data/newtype declaration"
96
97 ----------------------------------------------------------------------------
98 -- Various Syntactic Checks
99
100 callConvFM :: UniqFM CallConv
101 callConvFM = listToUFM $
102       map (\ (x,y) -> (_PK_ x,y))
103      [  ("stdcall",  stdCallConv),
104         ("ccall",    cCallConv)
105 --      ("pascal",   pascalCallConv),
106 --      ("fastcall", fastCallConv)
107      ]
108
109 checkCallConv :: FAST_STRING -> P CallConv
110 checkCallConv s = 
111   case lookupUFM callConvFM s of
112         Nothing -> parseError ("unknown calling convention: `"
113                                  ++ unpackFS s ++ "'")
114         Just conv -> returnP conv
115
116 checkInstType :: RdrNameHsType -> P RdrNameHsType
117 checkInstType t 
118   = case t of
119         HsForAllTy tvs ctxt ty ->
120                 checkAssertion ty [] `thenP` \(c,ts)->
121                 returnP (HsForAllTy tvs ctxt (MonoDictTy c ts))
122
123         ty ->   checkAssertion ty [] `thenP` \(c,ts)->
124                 returnP (HsForAllTy Nothing [] (MonoDictTy c ts))
125
126 checkContext :: RdrNameHsType -> P RdrNameContext
127 checkContext (MonoTupleTy ts True) 
128   = mapP (\t -> checkPred t []) ts `thenP` \ps ->
129     returnP ps
130 checkContext (MonoTyVar t) -- empty contexts are allowed
131   | t == unitTyCon_RDR = returnP []
132 checkContext t 
133   = checkPred t [] `thenP` \p ->
134     returnP [p]
135
136 checkPred :: RdrNameHsType -> [RdrNameHsType] 
137         -> P (HsPred RdrName)
138 checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) 
139         = returnP (HsPClass t args)
140 checkPred (MonoTyApp l r) args = checkPred l (r:args)
141 checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty)
142 checkPred _ _ = parseError "Illegal class assertion"
143
144 checkAssertion :: RdrNameHsType -> [RdrNameHsType] 
145         -> P (HsClassAssertion RdrName)
146 checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) 
147         = returnP (t,args)
148 checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
149 checkAssertion _ _ = parseError "Illegal class assertion"
150
151 checkDataHeader :: RdrNameHsType 
152         -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
153 checkDataHeader (HsForAllTy Nothing cs t) =
154    checkSimple t []          `thenP` \(c,ts) ->
155    returnP (cs,c,map UserTyVar ts)
156 checkDataHeader t =
157    checkSimple t []          `thenP` \(c,ts) ->
158    returnP ([],c,map UserTyVar ts)
159
160 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
161 checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a 
162    = checkSimple l (a:xs)
163 checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
164 checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
165
166 ---------------------------------------------------------------------------
167 -- Checking Patterns.
168
169 -- We parse patterns as expressions and check for valid patterns below,
170 -- nverting the expression into a pattern at the same time.
171
172 checkPattern :: RdrNameHsExpr -> P RdrNamePat
173 checkPattern e = checkPat e []
174
175 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
176 checkPatterns es = mapP checkPattern es
177
178 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
179 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
180 checkPat (HsApp f x) args = 
181         checkPat x [] `thenP` \x ->
182         checkPat f (x:args)
183 checkPat e [] = case e of
184         EWildPat           -> returnP WildPatIn
185         HsVar x            -> returnP (VarPatIn x)
186         HsLit l            -> returnP (LitPatIn l)
187         ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPatIn)
188         EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPatIn n)
189         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
190                               -- pattern signatures are parsed as sigtypes,
191                               -- but they aren't explicit forall points.  Hence
192                               -- we have to remove the implicit forall here.
193                               let t' = case t of 
194                                           HsForAllTy Nothing [] ty -> ty
195                                           other -> other
196                               in
197                               returnP (SigPatIn e t')
198
199         OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR
200                            -> returnP (NPlusKPatIn n k)
201
202         OpApp l op fix r   -> checkPat l [] `thenP` \l ->
203                               checkPat r [] `thenP` \r ->
204                               case op of
205                                  HsVar c -> returnP (ConOpPatIn l c fix r)
206                                  _ -> patFail
207
208         NegApp l r         -> checkPat l [] `thenP` (returnP . NegPatIn)
209         HsPar e            -> checkPat e [] `thenP` (returnP . ParPatIn)
210         ExplicitList es    -> mapP (\e -> checkPat e []) es `thenP` \ps ->
211                               returnP (ListPatIn ps)
212         ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
213                               returnP (TuplePatIn ps b)
214         RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
215                               returnP (RecPatIn c fs)
216         _ -> patFail
217
218 checkPat _ _ = patFail
219
220 checkPatField :: (RdrName, RdrNameHsExpr, Bool) 
221         -> P (RdrName, RdrNamePat, Bool)
222 checkPatField (n,e,b) =
223         checkPat e [] `thenP` \p ->
224         returnP (n,p,b)
225
226 patFail = parseError "Parse error in pattern"
227
228 ---------------------------------------------------------------------------
229 -- Check Expression Syntax
230
231 {-
232 We can get away without checkExpr if the renamer generates errors for
233 pattern syntax used in expressions (wildcards, as patterns and lazy 
234 patterns).
235
236 checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr
237 checkExpr e = case e of
238         HsVar _                   -> returnP e
239         HsIPVar _                 -> returnP e
240         HsLit _                   -> returnP e
241         HsLam match               -> checkMatch match `thenP` (returnP.HsLam)
242         HsApp e1 e2               -> check2Exprs e1 e2 HsApp
243         OpApp e1 e2 fix e3        -> checkExpr e1 `thenP` \e1 ->
244                                      checkExpr e2 `thenP` \e2 ->
245                                      checkExpr e3 `thenP` \e3 ->
246                                      returnP (OpApp e1 e2 fix e3)
247         NegApp e neg              -> checkExpr e `thenP` \e ->
248                                      returnP (NegApp e neg)
249         HsPar e                   -> check1Expr e HsPar
250         SectionL e1 e2            -> check2Exprs e1 e2 SectionL
251         SectionR e1 e2            -> check2Exprs e1 e2 SectionR
252         HsCase e alts             -> mapP checkMatch alts `thenP` \alts ->
253                                      checkExpr e `thenP` \e ->
254                                      returnP (HsCase e alts)
255         HsIf e1 e2 e3             -> check3Exprs e1 e2 e3 HsIf
256
257         HsLet bs e                -> check1Expr e (HsLet bs)
258         HsDo stmts                -> mapP checkStmt stmts `thenP` (returnP . HsDo)
259         HsTuple es                -> checkManyExprs es HsTuple
260         HsList es                 -> checkManyExprs es HsList
261         HsRecConstr c fields      -> mapP checkField fields `thenP` \fields ->
262                                      returnP (HsRecConstr c fields)
263         HsRecUpdate e fields      -> mapP checkField fields `thenP` \fields ->
264                                      checkExpr e `thenP` \e ->
265                                      returnP (HsRecUpdate e fields)
266         HsEnumFrom e              -> check1Expr e HsEnumFrom
267         HsEnumFromTo e1 e2        -> check2Exprs e1 e2 HsEnumFromTo
268         HsEnumFromThen e1 e2      -> check2Exprs e1 e2 HsEnumFromThen
269         HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo
270         HsListComp e stmts        -> mapP checkStmt stmts `thenP` \stmts ->
271                                      checkExpr e `thenP` \e ->
272                                      returnP (HsListComp e stmts)
273         RdrNameHsExprTypeSig loc e ty     -> checkExpr e `thenP` \e ->
274                                      returnP (RdrNameHsExprTypeSig loc e ty)
275         _                         -> parseError "parse error in expression"
276
277 -- type signature for polymorphic recursion!!
278 check1Expr :: RdrNameHsExpr -> (RdrNameHsExpr -> a) -> P a
279 check1Expr e f = checkExpr e `thenP` (returnP . f)
280
281 check2Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
282 check2Exprs e1 e2 f = 
283         checkExpr e1 `thenP` \e1 ->
284         checkExpr e2 `thenP` \e2 ->
285         returnP (f e1 e2)
286
287 check3Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
288 check3Exprs e1 e2 e3 f = 
289         checkExpr e1 `thenP` \e1 ->
290         checkExpr e2 `thenP` \e2 ->
291         checkExpr e3 `thenP` \e3 ->
292         returnP (f e1 e2 e3)
293
294 checkManyExprs es f =
295         mapP checkExpr es `thenP` \es ->
296         returnP (f es) 
297
298 checkAlt (HsAlt loc p galts bs) 
299         = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs)
300
301 checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt
302 checkGAlts (HsGuardedAlts galts) 
303     = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts)
304
305 checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc)
306
307 checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p)
308 checkStmt (HsQualifier e)   = check1Expr e HsQualifier
309 checkStmt s@(HsLetStmt bs)  = returnP s
310
311 checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
312 checkField e = returnP e
313 -}
314 ---------------------------------------------------------------------------
315 -- Check Equation Syntax
316
317 checkValDef 
318         :: RdrNameHsExpr
319         -> Maybe RdrNameHsType
320         -> RdrNameGRHSs
321         -> SrcLoc
322         -> P RdrBinding
323
324 checkValDef lhs opt_sig grhss loc
325  = case isFunLhs lhs [] of
326            Just (f,inf,es) -> 
327                 checkPatterns es `thenP` \ps ->
328                 returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
329
330            Nothing ->
331                 checkPattern lhs `thenP` \lhs ->
332                 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
333
334 checkValSig
335         :: RdrNameHsExpr
336         -> RdrNameHsType
337         -> SrcLoc
338         -> P RdrBinding
339 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
340 checkValSig other     ty loc = parseError "Type signature given for an expression"
341
342
343 -- A variable binding is parsed as an RdrNameFunMonoBind.
344 -- See comments with HsBinds.MonoBinds
345
346 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
347                                 = Just (op, True, (l:r:es))
348 isFunLhs (HsVar f) es | not (isRdrDataCon f)
349                                 = Just (f,False,es)
350 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
351 isFunLhs (HsPar e)   es         = isFunLhs e es
352 isFunLhs _ _                    = Nothing
353
354 ---------------------------------------------------------------------------
355 -- Miscellaneous utilities
356
357 checkPrec :: Integer -> P ()
358 checkPrec i | 0 <= i && i <= 9 = returnP ()
359             | otherwise        = parseError "precedence out of range"
360
361 mkRecConstrOrUpdate 
362         :: RdrNameHsExpr 
363         -> RdrNameHsRecordBinds
364         -> P RdrNameHsExpr
365
366 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
367   = returnP (RecordCon c fs)
368 mkRecConstrOrUpdate exp fs@(_:_) 
369   = returnP (RecordUpd exp fs)
370 mkRecConstrOrUpdate _ _
371   = parseError "Empty record update"
372
373 -- Supplying the ext_name in a foreign decl is optional ; if it
374 -- isn't there, the Haskell name is assumed. Note that no transformation
375 -- of the Haskell name is then performed, so if you foreign export (++),
376 -- it's external name will be "++". Too bad; it's important because we don't
377 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
378 -- (This is why we use occNameUserString.)
379 mkExtName :: Maybe ExtName -> RdrName -> ExtName
380 mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
381                                   Nothing
382 mkExtName (Just x) _    = x
383
384 -----------------------------------------------------------------------------
385 -- group function bindings into equation groups
386
387 -- we assume the bindings are coming in reverse order, so we take the srcloc
388 -- from the *last* binding in the group as the srcloc for the whole group.
389
390 groupBindings :: [RdrBinding] -> RdrBinding
391 groupBindings binds = group Nothing binds
392   where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
393         group (Just bind) [] = RdrValBinding bind
394         group Nothing [] = RdrNullBind
395         group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
396                     (RdrValBinding (FunMonoBind f' _ [mtch] loc) : binds)
397             | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
398
399         group (Just so_far) binds
400             = RdrValBinding so_far `RdrAndBindings` group Nothing binds
401         group Nothing (bind:binds)
402             = case bind of
403                 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
404                 other -> bind `RdrAndBindings` group Nothing binds
405
406 -----------------------------------------------------------------------------
407 -- Built-in names
408
409 unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
410 tupleCon_RDR, tupleTyCon_RDR            :: Int -> RdrName
411 ubxTupleCon_RDR, ubxTupleTyCon_RDR      :: Int -> RdrName
412
413 unitCon_RDR
414         | opt_NoImplicitPrelude = mkSrcUnqual   dataName unitName
415         | otherwise             = mkPreludeQual dataName pRELUDE_Name unitName
416
417 unitTyCon_RDR
418         | opt_NoImplicitPrelude = mkSrcUnqual   tcName unitName
419         | otherwise             = mkPreludeQual tcName pRELUDE_Name unitName
420
421 nilCon_RDR
422         | opt_NoImplicitPrelude = mkSrcUnqual   dataName listName
423         | otherwise             = mkPreludeQual dataName pRELUDE_Name listName
424
425 listTyCon_RDR
426         | opt_NoImplicitPrelude = mkSrcUnqual   tcName listName
427         | otherwise             = mkPreludeQual tcName pRELUDE_Name listName
428
429 funTyCon_RDR
430         | opt_NoImplicitPrelude = mkSrcUnqual   tcName funName
431         | otherwise             = mkPreludeQual tcName pRELUDE_Name funName
432
433 tupleCon_RDR arity
434   | opt_NoImplicitPrelude = mkSrcUnqual   dataName (snd (mkTupNameStr arity))
435   | otherwise             = mkPreludeQual dataName pRELUDE_Name
436                                 (snd (mkTupNameStr arity))
437
438 tupleTyCon_RDR arity
439   | opt_NoImplicitPrelude = mkSrcUnqual   tcName (snd (mkTupNameStr arity))
440   | otherwise             = mkPreludeQual tcName pRELUDE_Name
441                                 (snd (mkTupNameStr arity))
442
443
444 ubxTupleCon_RDR arity
445   | opt_NoImplicitPrelude = mkSrcUnqual   dataName (snd (mkUbxTupNameStr arity))
446   | otherwise             = mkPreludeQual dataName pRELUDE_Name 
447                                 (snd (mkUbxTupNameStr arity))
448
449 ubxTupleTyCon_RDR arity
450   | opt_NoImplicitPrelude = mkSrcUnqual   tcName (snd (mkUbxTupNameStr arity))
451   | otherwise             = mkPreludeQual tcName pRELUDE_Name 
452                                 (snd (mkUbxTupNameStr arity))
453
454 unitName = SLIT("()")
455 funName  = SLIT("(->)")
456 listName = SLIT("[]")
457
458 asName              = SLIT("as")
459 hidingName          = SLIT("hiding")
460 qualifiedName       = SLIT("qualified")
461 forallName          = SLIT("forall")
462 exportName          = SLIT("export")
463 labelName           = SLIT("label")
464 dynamicName         = SLIT("dynamic")
465 unsafeName          = SLIT("unsafe")
466 stdcallName         = SLIT("stdcall")
467 ccallName           = SLIT("ccall")
468
469 as_var_RDR          = mkSrcUnqual varName asName
470 hiding_var_RDR      = mkSrcUnqual varName hidingName
471 qualified_var_RDR   = mkSrcUnqual varName qualifiedName
472 forall_var_RDR      = mkSrcUnqual varName forallName
473 export_var_RDR      = mkSrcUnqual varName exportName
474 label_var_RDR       = mkSrcUnqual varName labelName
475 dynamic_var_RDR     = mkSrcUnqual varName dynamicName
476 unsafe_var_RDR      = mkSrcUnqual varName unsafeName
477 stdcall_var_RDR     = mkSrcUnqual varName stdcallName
478 ccall_var_RDR       = mkSrcUnqual varName ccallName
479
480 as_tyvar_RDR        = mkSrcUnqual tvName asName
481 hiding_tyvar_RDR    = mkSrcUnqual tvName hidingName
482 qualified_tyvar_RDR = mkSrcUnqual tvName qualifiedName
483 export_tyvar_RDR    = mkSrcUnqual tvName exportName
484 label_tyvar_RDR     = mkSrcUnqual tvName labelName
485 dynamic_tyvar_RDR   = mkSrcUnqual tvName dynamicName
486 unsafe_tyvar_RDR    = mkSrcUnqual tvName unsafeName
487 stdcall_tyvar_RDR   = mkSrcUnqual tvName stdcallName
488 ccall_tyvar_RDR     = mkSrcUnqual tvName ccallName
489
490 minus_RDR           = mkSrcUnqual varName SLIT("-")
491 pling_RDR           = mkSrcUnqual varName SLIT("!")
492 dot_RDR             = mkSrcUnqual varName SLIT(".")
493
494 plus_RDR            = mkSrcUnqual varName SLIT("+")
495 \end{code}