2 % (c) The GRASP/AQUA Project, Glasgow University, 1999
4 \section[ParseUtil]{Parser Utilities}
8 parseError -- String -> Pa
9 , srcParseErr -- StringBuffer -> SrcLoc -> Message
11 , splitForConApp -- RdrNameHsType -> [RdrNameBangType]
12 -- -> P (RdrName, [RdrNameBangType])
14 , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
21 , checkPrec -- String -> P String
22 , checkCallConv -- FAST_STRING -> P CallConv
23 , checkContext -- HsType -> P HsContext
24 , checkInstType -- HsType -> P HsType
25 , checkAssertion -- HsType -> P HsAsst
26 , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])
27 , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName]))
28 , checkPattern -- HsExp -> P HsPat
29 , checkPatterns -- [HsExp] -> P [HsPat]
30 -- , checkExpr -- HsExp -> P HsExp
31 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
34 -- some built-in names (all :: RdrName)
35 , unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR
36 , tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR
39 -- pseudo-keywords, in var and tyvar forms (all :: RdrName)
41 , export_var_RDR, label_var_RDR, dynamic_var_RDR, unsafe_var_RDR
43 , export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR
46 , minus_RDR, pling_RDR, dot_RDR
50 #include "HsVersions.h"
58 import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
59 import OccName ( dataName, tcName, varName, tvName, setOccNameSpace )
60 import CmdLineOpts ( opt_NoImplicitPrelude )
61 import StringBuffer ( lexemeToString )
62 import FastString ( unpackFS )
64 import UniqFM ( UniqFM, listToUFM, lookupUFM )
67 -----------------------------------------------------------------------------
70 parseError :: String -> P a
72 getSrcLocP `thenP` \ loc ->
73 failMsgP (hcat [ppr loc, text ": ", text s])
75 parseErrorOnInput :: P a
76 parseErrorOnInput buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
78 srcParseErr :: StringBuffer -> SrcLoc -> Message
80 = hcat [ppr l, ptext SLIT(": parse error on input "),
81 char '`', text (lexemeToString s), char '\'']
83 cbot = panic "CCall:result_ty"
85 -----------------------------------------------------------------------------
88 checkAs, checkQualified, checkHiding :: FAST_STRING -> P ()
90 checkAs s | s == SLIT("as") = returnP ()
91 | otherwise = parseErrorOnInput
92 checkQualified s | s == SLIT("qualified") = returnP ()
93 | otherwise = parseErrorOnInput
94 checkHiding s | s == SLIT("hiding") = returnP ()
95 | otherwise = parseErrorOnInput
97 -----------------------------------------------------------------------------
100 -- When parsing data declarations, we sometimes inadvertently parse
101 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
102 -- This function splits up the type application, adds any pending
103 -- arguments, and converts the type constructor back into a data constructor.
105 splitForConApp :: RdrNameHsType -> [RdrNameBangType]
106 -> P (RdrName, [RdrNameBangType])
108 splitForConApp t ts = split t ts
110 split (MonoTyApp t u) ts = split t (Unbanged u : ts)
112 split (MonoTyVar t) ts = returnP (con, ts)
113 where t_occ = rdrNameOcc t
114 con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
116 split _ _ = parseError "Illegal data/newtype declaration"
118 ----------------------------------------------------------------------------
119 -- Various Syntactic Checks
121 callConvFM :: UniqFM CallConv
122 callConvFM = listToUFM $
123 map (\ (x,y) -> (_PK_ x,y))
124 [ ("stdcall", stdCallConv),
126 -- ("pascal", pascalCallConv),
127 -- ("fastcall", fastCallConv)
130 checkCallConv :: FAST_STRING -> P CallConv
132 case lookupUFM callConvFM s of
133 Nothing -> parseError ("unknown calling convention: `"
134 ++ unpackFS s ++ "'")
135 Just conv -> returnP conv
137 checkInstType :: RdrNameHsType -> P RdrNameHsType
140 HsForAllTy tvs ctxt ty ->
141 checkAssertion ty [] `thenP` \(c,ts)->
142 returnP (HsForAllTy tvs ctxt (MonoDictTy c ts))
144 ty -> checkAssertion ty [] `thenP` \(c,ts)->
145 returnP (HsForAllTy Nothing [] (MonoDictTy c ts))
147 checkContext :: RdrNameHsType -> P RdrNameContext
148 checkContext (MonoTupleTy ts True)
149 = mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
151 checkContext (MonoTyVar t) -- empty contexts are allowed
152 | t == unitTyCon_RDR = returnP []
154 = checkAssertion t [] `thenP` \c ->
157 checkAssertion :: RdrNameHsType -> [RdrNameHsType]
158 -> P (ClassAssertion RdrName)
159 checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
161 checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
162 checkAssertion _ _ = parseError "Illegal class assertion"
164 checkDataHeader :: RdrNameHsType
165 -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
166 checkDataHeader (HsForAllTy Nothing cs t) =
167 checkSimple t [] `thenP` \(c,ts) ->
168 returnP (cs,c,map UserTyVar ts)
170 checkSimple t [] `thenP` \(c,ts) ->
171 returnP ([],c,map UserTyVar ts)
173 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
174 checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a
175 = checkSimple l (a:xs)
176 checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
177 checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
179 ---------------------------------------------------------------------------
180 -- Checking Patterns.
182 -- We parse patterns as expressions and check for valid patterns below,
183 -- nverting the expression into a pattern at the same time.
185 checkPattern :: RdrNameHsExpr -> P RdrNamePat
186 checkPattern e = checkPat e []
188 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
189 checkPatterns es = mapP checkPattern es
191 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
192 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
193 checkPat (HsApp f x) args =
194 checkPat x [] `thenP` \x ->
196 checkPat e [] = case e of
197 EWildPat -> returnP WildPatIn
198 HsVar x -> returnP (VarPatIn x)
199 HsLit l -> returnP (LitPatIn l)
200 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
201 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
202 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
203 -- pattern signatures are parsed as sigtypes,
204 -- but they aren't explicit forall points. Hence
205 -- we have to remove the implicit forall here.
207 HsForAllTy Nothing [] ty -> ty
210 returnP (SigPatIn e t')
212 OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR
213 -> returnP (NPlusKPatIn n k)
215 OpApp l op fix r -> checkPat l [] `thenP` \l ->
216 checkPat r [] `thenP` \r ->
218 HsVar c -> returnP (ConOpPatIn l c fix r)
221 NegApp l r -> checkPat l [] `thenP` (returnP . NegPatIn)
222 HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
223 ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
224 returnP (ListPatIn ps)
225 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
226 returnP (TuplePatIn ps b)
227 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
228 returnP (RecPatIn c fs)
231 checkPat _ _ = patFail
233 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
234 -> P (RdrName, RdrNamePat, Bool)
235 checkPatField (n,e,b) =
236 checkPat e [] `thenP` \p ->
239 patFail = parseError "Parse error in pattern"
241 ---------------------------------------------------------------------------
242 -- Check Expression Syntax
245 We can get away without checkExpr if the renamer generates errors for
246 pattern syntax used in expressions (wildcards, as patterns and lazy
249 checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr
250 checkExpr e = case e of
253 HsLam match -> checkMatch match `thenP` (returnP.HsLam)
254 HsApp e1 e2 -> check2Exprs e1 e2 HsApp
255 OpApp e1 e2 fix e3 -> checkExpr e1 `thenP` \e1 ->
256 checkExpr e2 `thenP` \e2 ->
257 checkExpr e3 `thenP` \e3 ->
258 returnP (OpApp e1 e2 fix e3)
259 NegApp e neg -> checkExpr e `thenP` \e ->
260 returnP (NegApp e neg)
261 HsPar e -> check1Expr e HsPar
262 SectionL e1 e2 -> check2Exprs e1 e2 SectionL
263 SectionR e1 e2 -> check2Exprs e1 e2 SectionR
264 HsCase e alts -> mapP checkMatch alts `thenP` \alts ->
265 checkExpr e `thenP` \e ->
266 returnP (HsCase e alts)
267 HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf
269 HsLet bs e -> check1Expr e (HsLet bs)
270 HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo)
271 HsTuple es -> checkManyExprs es HsTuple
272 HsList es -> checkManyExprs es HsList
273 HsRecConstr c fields -> mapP checkField fields `thenP` \fields ->
274 returnP (HsRecConstr c fields)
275 HsRecUpdate e fields -> mapP checkField fields `thenP` \fields ->
276 checkExpr e `thenP` \e ->
277 returnP (HsRecUpdate e fields)
278 HsEnumFrom e -> check1Expr e HsEnumFrom
279 HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo
280 HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen
281 HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo
282 HsListComp e stmts -> mapP checkStmt stmts `thenP` \stmts ->
283 checkExpr e `thenP` \e ->
284 returnP (HsListComp e stmts)
285 RdrNameHsExprTypeSig loc e ty -> checkExpr e `thenP` \e ->
286 returnP (RdrNameHsExprTypeSig loc e ty)
287 _ -> parseError "parse error in expression"
289 -- type signature for polymorphic recursion!!
290 check1Expr :: RdrNameHsExpr -> (RdrNameHsExpr -> a) -> P a
291 check1Expr e f = checkExpr e `thenP` (returnP . f)
293 check2Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
294 check2Exprs e1 e2 f =
295 checkExpr e1 `thenP` \e1 ->
296 checkExpr e2 `thenP` \e2 ->
299 check3Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
300 check3Exprs e1 e2 e3 f =
301 checkExpr e1 `thenP` \e1 ->
302 checkExpr e2 `thenP` \e2 ->
303 checkExpr e3 `thenP` \e3 ->
306 checkManyExprs es f =
307 mapP checkExpr es `thenP` \es ->
310 checkAlt (HsAlt loc p galts bs)
311 = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs)
313 checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt
314 checkGAlts (HsGuardedAlts galts)
315 = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts)
317 checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc)
319 checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p)
320 checkStmt (HsQualifier e) = check1Expr e HsQualifier
321 checkStmt s@(HsLetStmt bs) = returnP s
323 checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
324 checkField e = returnP e
326 ---------------------------------------------------------------------------
327 -- Check Equation Syntax
331 -> Maybe RdrNameHsType
334 -> P RdrNameMonoBinds
336 checkValDef lhs opt_sig grhss loc
337 = case isFunLhs lhs [] of
339 checkPatterns es `thenP` \ps ->
340 returnP (FunMonoBind f inf [Match [] ps opt_sig grhss] loc)
343 checkPattern lhs `thenP` \lhs ->
344 returnP (PatMonoBind lhs grhss loc)
346 -- A variable binding is parsed as an RdrNamePatBind.
348 isFunLhs (OpApp l (HsVar op) fix r) [] | not (isRdrDataCon op)
349 = Just (op, True, [l,r])
350 isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f)
352 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
353 isFunLhs (HsPar e) es = isFunLhs e es
354 isFunLhs _ _ = Nothing
356 ---------------------------------------------------------------------------
357 -- Miscellaneous utilities
359 checkPrec :: Integer -> P ()
360 checkPrec i | 0 <= i && i <= 9 = returnP ()
361 | otherwise = parseError "precedence out of range"
365 -> RdrNameHsRecordBinds
368 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
369 = returnP (RecordCon c fs)
370 mkRecConstrOrUpdate exp fs@(_:_)
371 = returnP (RecordUpd exp fs)
372 mkRecConstrOrUpdate _ _
373 = parseError "Empty record update"
375 -----------------------------------------------------------------------------
376 -- group function bindings into equation groups
378 -- we assume the bindings are coming in reverse order, so we take the srcloc
379 -- from the *last* binding in the group as the srcloc for the whole group.
381 groupBindings :: [RdrBinding] -> RdrBinding
382 groupBindings binds = group Nothing binds
383 where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
384 group (Just bind) [] = RdrValBinding bind
385 group Nothing [] = RdrNullBind
386 group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
387 (RdrValBinding (FunMonoBind f' _ [mtch] loc) : binds)
388 | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
390 group (Just so_far) binds
391 = RdrValBinding so_far `RdrAndBindings` group Nothing binds
392 group Nothing (bind:binds)
394 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
395 other -> bind `RdrAndBindings` group Nothing binds
397 -----------------------------------------------------------------------------
400 unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
401 tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName
402 ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName
405 | opt_NoImplicitPrelude = mkSrcUnqual dataName unitName
406 | otherwise = mkPreludeQual dataName pRELUDE_Name unitName
409 | opt_NoImplicitPrelude = mkSrcUnqual tcName unitName
410 | otherwise = mkPreludeQual tcName pRELUDE_Name unitName
413 | opt_NoImplicitPrelude = mkSrcUnqual dataName listName
414 | otherwise = mkPreludeQual dataName pRELUDE_Name listName
417 | opt_NoImplicitPrelude = mkSrcUnqual tcName listName
418 | otherwise = mkPreludeQual tcName pRELUDE_Name listName
421 | opt_NoImplicitPrelude = mkSrcUnqual tcName funName
422 | otherwise = mkPreludeQual tcName pRELUDE_Name funName
425 | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr arity))
426 | otherwise = mkPreludeQual dataName pRELUDE_Name
427 (snd (mkTupNameStr arity))
430 | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity))
431 | otherwise = mkPreludeQual tcName pRELUDE_Name
432 (snd (mkTupNameStr arity))
435 ubxTupleCon_RDR arity
436 | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity))
437 | otherwise = mkPreludeQual dataName pRELUDE_Name
438 (snd (mkUbxTupNameStr arity))
440 ubxTupleTyCon_RDR arity
441 | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity))
442 | otherwise = mkPreludeQual tcName pRELUDE_Name
443 (snd (mkUbxTupNameStr arity))
445 unitName = SLIT("()")
446 funName = SLIT("(->)")
447 listName = SLIT("[]")
449 forallName = SLIT("forall")
450 exportName = SLIT("export")
451 labelName = SLIT("label")
452 dynamicName = SLIT("dynamic")
453 unsafeName = SLIT("unsafe")
455 forall_var_RDR = mkSrcUnqual varName forallName
456 export_var_RDR = mkSrcUnqual varName exportName
457 label_var_RDR = mkSrcUnqual varName labelName
458 dynamic_var_RDR = mkSrcUnqual varName dynamicName
459 unsafe_var_RDR = mkSrcUnqual varName unsafeName
461 export_tyvar_RDR = mkSrcUnqual tvName exportName
462 label_tyvar_RDR = mkSrcUnqual tvName labelName
463 dynamic_tyvar_RDR = mkSrcUnqual tvName dynamicName
464 unsafe_tyvar_RDR = mkSrcUnqual tvName unsafeName
466 minus_RDR = mkSrcUnqual varName SLIT("-")
467 pling_RDR = mkSrcUnqual varName SLIT("!")
468 dot_RDR = mkSrcUnqual varName SLIT(".")
470 plus_RDR = mkSrcUnqual varName SLIT("+")