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
17 , checkPrec -- String -> P String
18 , checkCallConv -- FAST_STRING -> P CallConv
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
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
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
39 , as_tyvar_RDR, hiding_tyvar_RDR, qualified_tyvar_RDR
40 , export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR
43 , minus_RDR, pling_RDR, dot_RDR
47 #include "HsVersions.h"
55 import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
56 import OccName ( dataName, tcName, varName, tvName, setOccNameSpace )
57 import CmdLineOpts ( opt_NoImplicitPrelude )
58 import StringBuffer ( lexemeToString )
59 import FastString ( unpackFS )
61 import UniqFM ( UniqFM, listToUFM, lookupUFM )
64 -----------------------------------------------------------------------------
67 parseError :: String -> P a
69 getSrcLocP `thenP` \ loc ->
70 failMsgP (hcat [ppr loc, text ": ", text s])
72 srcParseErr :: StringBuffer -> SrcLoc -> Message
74 = hcat [ppr l, ptext SLIT(": parse error on input "),
75 char '`', text (lexemeToString s), char '\'']
77 cbot = panic "CCall:result_ty"
79 -----------------------------------------------------------------------------
82 -- When parsing data declarations, we sometimes inadvertently parse
83 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
84 -- This function splits up the type application, adds any pending
85 -- arguments, and converts the type constructor back into a data constructor.
87 splitForConApp :: RdrNameHsType -> [RdrNameBangType]
88 -> P (RdrName, [RdrNameBangType])
90 splitForConApp t ts = split t ts
92 split (MonoTyApp t u) ts = split t (Unbanged u : ts)
94 split (MonoTyVar t) ts = returnP (con, ts)
95 where t_occ = rdrNameOcc t
96 con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
98 split _ _ = parseError "Illegal data/newtype declaration"
100 ----------------------------------------------------------------------------
101 -- Various Syntactic Checks
103 callConvFM :: UniqFM CallConv
104 callConvFM = listToUFM $
105 map (\ (x,y) -> (_PK_ x,y))
106 [ ("stdcall", stdCallConv),
108 -- ("pascal", pascalCallConv),
109 -- ("fastcall", fastCallConv)
112 checkCallConv :: FAST_STRING -> P CallConv
114 case lookupUFM callConvFM s of
115 Nothing -> parseError ("unknown calling convention: `"
116 ++ unpackFS s ++ "'")
117 Just conv -> returnP conv
119 checkInstType :: RdrNameHsType -> P RdrNameHsType
122 HsForAllTy tvs ctxt ty ->
123 checkAssertion ty [] `thenP` \(c,ts)->
124 returnP (HsForAllTy tvs ctxt (MonoDictTy c ts))
126 ty -> checkAssertion ty [] `thenP` \(c,ts)->
127 returnP (HsForAllTy Nothing [] (MonoDictTy c ts))
129 checkContext :: RdrNameHsType -> P RdrNameContext
130 checkContext (MonoTupleTy ts True)
131 = mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
133 checkContext (MonoTyVar t) -- empty contexts are allowed
134 | t == unitTyCon_RDR = returnP []
136 = checkAssertion t [] `thenP` \c ->
139 checkAssertion :: RdrNameHsType -> [RdrNameHsType]
140 -> P (ClassAssertion RdrName)
141 checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
143 checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
144 checkAssertion _ _ = parseError "Illegal class assertion"
146 checkDataHeader :: RdrNameHsType
147 -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
148 checkDataHeader (HsForAllTy Nothing cs t) =
149 checkSimple t [] `thenP` \(c,ts) ->
150 returnP (cs,c,map UserTyVar ts)
152 checkSimple t [] `thenP` \(c,ts) ->
153 returnP ([],c,map UserTyVar ts)
155 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
156 checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a
157 = checkSimple l (a:xs)
158 checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
159 checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
161 ---------------------------------------------------------------------------
162 -- Checking Patterns.
164 -- We parse patterns as expressions and check for valid patterns below,
165 -- nverting the expression into a pattern at the same time.
167 checkPattern :: RdrNameHsExpr -> P RdrNamePat
168 checkPattern e = checkPat e []
170 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
171 checkPatterns es = mapP checkPattern es
173 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
174 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
175 checkPat (HsApp f x) args =
176 checkPat x [] `thenP` \x ->
178 checkPat e [] = case e of
179 EWildPat -> returnP WildPatIn
180 HsVar x -> returnP (VarPatIn x)
181 HsLit l -> returnP (LitPatIn l)
182 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
183 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
184 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
185 -- pattern signatures are parsed as sigtypes,
186 -- but they aren't explicit forall points. Hence
187 -- we have to remove the implicit forall here.
189 HsForAllTy Nothing [] ty -> ty
192 returnP (SigPatIn e t')
194 OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR
195 -> returnP (NPlusKPatIn n k)
197 OpApp l op fix r -> checkPat l [] `thenP` \l ->
198 checkPat r [] `thenP` \r ->
200 HsVar c -> returnP (ConOpPatIn l c fix r)
203 NegApp l r -> checkPat l [] `thenP` (returnP . NegPatIn)
204 HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
205 ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
206 returnP (ListPatIn ps)
207 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
208 returnP (TuplePatIn ps b)
209 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
210 returnP (RecPatIn c fs)
213 checkPat _ _ = patFail
215 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
216 -> P (RdrName, RdrNamePat, Bool)
217 checkPatField (n,e,b) =
218 checkPat e [] `thenP` \p ->
221 patFail = parseError "Parse error in pattern"
223 ---------------------------------------------------------------------------
224 -- Check Expression Syntax
227 We can get away without checkExpr if the renamer generates errors for
228 pattern syntax used in expressions (wildcards, as patterns and lazy
231 checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr
232 checkExpr e = case e of
235 HsLam match -> checkMatch match `thenP` (returnP.HsLam)
236 HsApp e1 e2 -> check2Exprs e1 e2 HsApp
237 OpApp e1 e2 fix e3 -> checkExpr e1 `thenP` \e1 ->
238 checkExpr e2 `thenP` \e2 ->
239 checkExpr e3 `thenP` \e3 ->
240 returnP (OpApp e1 e2 fix e3)
241 NegApp e neg -> checkExpr e `thenP` \e ->
242 returnP (NegApp e neg)
243 HsPar e -> check1Expr e HsPar
244 SectionL e1 e2 -> check2Exprs e1 e2 SectionL
245 SectionR e1 e2 -> check2Exprs e1 e2 SectionR
246 HsCase e alts -> mapP checkMatch alts `thenP` \alts ->
247 checkExpr e `thenP` \e ->
248 returnP (HsCase e alts)
249 HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf
251 HsLet bs e -> check1Expr e (HsLet bs)
252 HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo)
253 HsTuple es -> checkManyExprs es HsTuple
254 HsList es -> checkManyExprs es HsList
255 HsRecConstr c fields -> mapP checkField fields `thenP` \fields ->
256 returnP (HsRecConstr c fields)
257 HsRecUpdate e fields -> mapP checkField fields `thenP` \fields ->
258 checkExpr e `thenP` \e ->
259 returnP (HsRecUpdate e fields)
260 HsEnumFrom e -> check1Expr e HsEnumFrom
261 HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo
262 HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen
263 HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo
264 HsListComp e stmts -> mapP checkStmt stmts `thenP` \stmts ->
265 checkExpr e `thenP` \e ->
266 returnP (HsListComp e stmts)
267 RdrNameHsExprTypeSig loc e ty -> checkExpr e `thenP` \e ->
268 returnP (RdrNameHsExprTypeSig loc e ty)
269 _ -> parseError "parse error in expression"
271 -- type signature for polymorphic recursion!!
272 check1Expr :: RdrNameHsExpr -> (RdrNameHsExpr -> a) -> P a
273 check1Expr e f = checkExpr e `thenP` (returnP . f)
275 check2Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
276 check2Exprs e1 e2 f =
277 checkExpr e1 `thenP` \e1 ->
278 checkExpr e2 `thenP` \e2 ->
281 check3Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
282 check3Exprs e1 e2 e3 f =
283 checkExpr e1 `thenP` \e1 ->
284 checkExpr e2 `thenP` \e2 ->
285 checkExpr e3 `thenP` \e3 ->
288 checkManyExprs es f =
289 mapP checkExpr es `thenP` \es ->
292 checkAlt (HsAlt loc p galts bs)
293 = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs)
295 checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt
296 checkGAlts (HsGuardedAlts galts)
297 = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts)
299 checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc)
301 checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p)
302 checkStmt (HsQualifier e) = check1Expr e HsQualifier
303 checkStmt s@(HsLetStmt bs) = returnP s
305 checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
306 checkField e = returnP e
308 ---------------------------------------------------------------------------
309 -- Check Equation Syntax
313 -> Maybe RdrNameHsType
316 -> P RdrNameMonoBinds
318 checkValDef lhs opt_sig grhss loc
319 = case isFunLhs lhs [] of
321 checkPatterns es `thenP` \ps ->
322 returnP (FunMonoBind f inf [Match [] ps opt_sig grhss] loc)
325 checkPattern lhs `thenP` \lhs ->
326 returnP (PatMonoBind lhs grhss loc)
328 -- A variable binding is parsed as an RdrNamePatBind.
330 isFunLhs (OpApp l (HsVar op) fix r) [] | not (isRdrDataCon op)
331 = Just (op, True, [l,r])
332 isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f)
334 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
335 isFunLhs (HsPar e) es = isFunLhs e es
336 isFunLhs _ _ = Nothing
338 ---------------------------------------------------------------------------
339 -- Miscellaneous utilities
341 checkPrec :: Integer -> P ()
342 checkPrec i | 0 <= i && i <= 9 = returnP ()
343 | otherwise = parseError "precedence out of range"
347 -> RdrNameHsRecordBinds
350 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
351 = returnP (RecordCon c fs)
352 mkRecConstrOrUpdate exp fs@(_:_)
353 = returnP (RecordUpd exp fs)
354 mkRecConstrOrUpdate _ _
355 = parseError "Empty record update"
357 -----------------------------------------------------------------------------
358 -- group function bindings into equation groups
360 -- we assume the bindings are coming in reverse order, so we take the srcloc
361 -- from the *last* binding in the group as the srcloc for the whole group.
363 groupBindings :: [RdrBinding] -> RdrBinding
364 groupBindings binds = group Nothing binds
365 where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
366 group (Just bind) [] = RdrValBinding bind
367 group Nothing [] = RdrNullBind
368 group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
369 (RdrValBinding (FunMonoBind f' _ [mtch] loc) : binds)
370 | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
372 group (Just so_far) binds
373 = RdrValBinding so_far `RdrAndBindings` group Nothing binds
374 group Nothing (bind:binds)
376 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
377 other -> bind `RdrAndBindings` group Nothing binds
379 -----------------------------------------------------------------------------
382 unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
383 tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName
384 ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName
387 | opt_NoImplicitPrelude = mkSrcUnqual dataName unitName
388 | otherwise = mkPreludeQual dataName pRELUDE_Name unitName
391 | opt_NoImplicitPrelude = mkSrcUnqual tcName unitName
392 | otherwise = mkPreludeQual tcName pRELUDE_Name unitName
395 | opt_NoImplicitPrelude = mkSrcUnqual dataName listName
396 | otherwise = mkPreludeQual dataName pRELUDE_Name listName
399 | opt_NoImplicitPrelude = mkSrcUnqual tcName listName
400 | otherwise = mkPreludeQual tcName pRELUDE_Name listName
403 | opt_NoImplicitPrelude = mkSrcUnqual tcName funName
404 | otherwise = mkPreludeQual tcName pRELUDE_Name funName
407 | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr arity))
408 | otherwise = mkPreludeQual dataName pRELUDE_Name
409 (snd (mkTupNameStr arity))
412 | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity))
413 | otherwise = mkPreludeQual tcName pRELUDE_Name
414 (snd (mkTupNameStr arity))
417 ubxTupleCon_RDR arity
418 | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity))
419 | otherwise = mkPreludeQual dataName pRELUDE_Name
420 (snd (mkUbxTupNameStr arity))
422 ubxTupleTyCon_RDR arity
423 | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity))
424 | otherwise = mkPreludeQual tcName pRELUDE_Name
425 (snd (mkUbxTupNameStr arity))
427 unitName = SLIT("()")
428 funName = SLIT("(->)")
429 listName = SLIT("[]")
432 hidingName = SLIT("hiding")
433 qualifiedName = SLIT("qualified")
434 forallName = SLIT("forall")
435 exportName = SLIT("export")
436 labelName = SLIT("label")
437 dynamicName = SLIT("dynamic")
438 unsafeName = SLIT("unsafe")
440 as_var_RDR = mkSrcUnqual varName asName
441 hiding_var_RDR = mkSrcUnqual varName hidingName
442 qualified_var_RDR = mkSrcUnqual varName qualifiedName
443 forall_var_RDR = mkSrcUnqual varName forallName
444 export_var_RDR = mkSrcUnqual varName exportName
445 label_var_RDR = mkSrcUnqual varName labelName
446 dynamic_var_RDR = mkSrcUnqual varName dynamicName
447 unsafe_var_RDR = mkSrcUnqual varName unsafeName
449 as_tyvar_RDR = mkSrcUnqual tvName asName
450 hiding_tyvar_RDR = mkSrcUnqual tvName hidingName
451 qualified_tyvar_RDR = mkSrcUnqual tvName qualifiedName
452 export_tyvar_RDR = mkSrcUnqual tvName exportName
453 label_tyvar_RDR = mkSrcUnqual tvName labelName
454 dynamic_tyvar_RDR = mkSrcUnqual tvName dynamicName
455 unsafe_tyvar_RDR = mkSrcUnqual tvName unsafeName
457 minus_RDR = mkSrcUnqual varName SLIT("-")
458 pling_RDR = mkSrcUnqual varName SLIT("!")
459 dot_RDR = mkSrcUnqual varName SLIT(".")
461 plus_RDR = mkSrcUnqual varName SLIT("+")