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