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