2 % (c) The GRASP/AQUA Project, Glasgow University, 1999
4 \section[ParseUtil]{Parser Utilities}
8 parseError -- String -> Pa
10 , splitForConApp -- RdrNameHsType -> [RdrNameBangType]
11 -- -> P (RdrName, [RdrNameBangType])
13 , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
16 , mkExtName -- Maybe ExtName -> RdrName -> ExtName
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
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
38 , stdcall_var_RDR, ccall_var_RDR
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
44 , minus_RDR, pling_RDR, dot_RDR
48 #include "HsVersions.h"
56 import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
57 import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameFS )
58 import CmdLineOpts ( opt_NoImplicitPrelude )
59 import StringBuffer ( lexemeToString )
60 import FastString ( unpackFS )
62 import UniqFM ( UniqFM, listToUFM, lookupUFM )
65 -----------------------------------------------------------------------------
68 parseError :: String -> P a
70 getSrcLocP `thenP` \ loc ->
71 failMsgP (hcat [ppr loc, text ": ", text s])
73 cbot = panic "CCall:result_ty"
75 -----------------------------------------------------------------------------
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.
83 splitForConApp :: RdrNameHsType -> [RdrNameBangType]
84 -> P (RdrName, [RdrNameBangType])
86 splitForConApp t ts = split t ts
88 split (MonoTyApp t u) ts = split t (Unbanged u : ts)
90 split (MonoTyVar t) ts = returnP (con, ts)
91 where t_occ = rdrNameOcc t
92 con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
94 split _ _ = parseError "Illegal data/newtype declaration"
96 ----------------------------------------------------------------------------
97 -- Various Syntactic Checks
99 callConvFM :: UniqFM CallConv
100 callConvFM = listToUFM $
101 map (\ (x,y) -> (_PK_ x,y))
102 [ ("stdcall", stdCallConv),
104 -- ("pascal", pascalCallConv),
105 -- ("fastcall", fastCallConv)
108 checkCallConv :: FAST_STRING -> P CallConv
110 case lookupUFM callConvFM s of
111 Nothing -> parseError ("unknown calling convention: `"
112 ++ unpackFS s ++ "'")
113 Just conv -> returnP conv
115 checkInstType :: RdrNameHsType -> P RdrNameHsType
118 HsForAllTy tvs ctxt ty ->
119 checkAssertion ty [] `thenP` \(c,ts)->
120 returnP (HsForAllTy tvs ctxt (MonoDictTy c ts))
122 ty -> checkAssertion ty [] `thenP` \(c,ts)->
123 returnP (HsForAllTy Nothing [] (MonoDictTy c ts))
125 checkContext :: RdrNameHsType -> P RdrNameContext
126 checkContext (MonoTupleTy ts True)
127 = mapP (\t -> checkPred t []) ts `thenP` \ps ->
129 checkContext (MonoTyVar t) -- empty contexts are allowed
130 | t == unitTyCon_RDR = returnP []
132 = checkPred t [] `thenP` \p ->
135 checkPred :: RdrNameHsType -> [RdrNameHsType]
136 -> P (HsPred RdrName)
137 checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
138 = returnP (HsPClass t args)
139 checkPred (MonoTyApp l r) args = checkPred l (r:args)
140 checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty)
141 checkPred _ _ = parseError "Illegal class assertion"
143 checkAssertion :: RdrNameHsType -> [RdrNameHsType]
144 -> P (HsClassAssertion RdrName)
145 checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
147 checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
148 checkAssertion _ _ = parseError "Illegal class assertion"
150 checkDataHeader :: RdrNameHsType
151 -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
152 checkDataHeader (HsForAllTy Nothing cs t) =
153 checkSimple t [] `thenP` \(c,ts) ->
154 returnP (cs,c,map UserTyVar ts)
156 checkSimple t [] `thenP` \(c,ts) ->
157 returnP ([],c,map UserTyVar ts)
159 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
160 checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a
161 = checkSimple l (a:xs)
162 checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
163 checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
165 ---------------------------------------------------------------------------
166 -- Checking Patterns.
168 -- We parse patterns as expressions and check for valid patterns below,
169 -- nverting the expression into a pattern at the same time.
171 checkPattern :: RdrNameHsExpr -> P RdrNamePat
172 checkPattern e = checkPat e []
174 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
175 checkPatterns es = mapP checkPattern es
177 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
178 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
179 checkPat (HsApp f x) args =
180 checkPat x [] `thenP` \x ->
182 checkPat e [] = case e of
183 EWildPat -> returnP WildPatIn
184 HsVar x -> returnP (VarPatIn x)
185 HsLit l -> returnP (LitPatIn l)
186 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
187 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
188 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
189 -- pattern signatures are parsed as sigtypes,
190 -- but they aren't explicit forall points. Hence
191 -- we have to remove the implicit forall here.
193 HsForAllTy Nothing [] ty -> ty
196 returnP (SigPatIn e t')
198 OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR
199 -> returnP (NPlusKPatIn n k)
201 OpApp l op fix r -> checkPat l [] `thenP` \l ->
202 checkPat r [] `thenP` \r ->
204 HsVar c -> returnP (ConOpPatIn l c fix r)
207 NegApp l r -> checkPat l [] `thenP` (returnP . NegPatIn)
208 HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
209 ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
210 returnP (ListPatIn ps)
211 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
212 returnP (TuplePatIn ps b)
213 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
214 returnP (RecPatIn c fs)
217 checkPat _ _ = patFail
219 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
220 -> P (RdrName, RdrNamePat, Bool)
221 checkPatField (n,e,b) =
222 checkPat e [] `thenP` \p ->
225 patFail = parseError "Parse error in pattern"
227 ---------------------------------------------------------------------------
228 -- Check Expression Syntax
231 We can get away without checkExpr if the renamer generates errors for
232 pattern syntax used in expressions (wildcards, as patterns and lazy
235 checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr
236 checkExpr e = case e of
238 HsIPVar _ -> returnP e
240 HsLam match -> checkMatch match `thenP` (returnP.HsLam)
241 HsApp e1 e2 -> check2Exprs e1 e2 HsApp
242 OpApp e1 e2 fix e3 -> checkExpr e1 `thenP` \e1 ->
243 checkExpr e2 `thenP` \e2 ->
244 checkExpr e3 `thenP` \e3 ->
245 returnP (OpApp e1 e2 fix e3)
246 NegApp e neg -> checkExpr e `thenP` \e ->
247 returnP (NegApp e neg)
248 HsPar e -> check1Expr e HsPar
249 SectionL e1 e2 -> check2Exprs e1 e2 SectionL
250 SectionR e1 e2 -> check2Exprs e1 e2 SectionR
251 HsCase e alts -> mapP checkMatch alts `thenP` \alts ->
252 checkExpr e `thenP` \e ->
253 returnP (HsCase e alts)
254 HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf
256 HsLet bs e -> check1Expr e (HsLet bs)
257 HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo)
258 HsTuple es -> checkManyExprs es HsTuple
259 HsList es -> checkManyExprs es HsList
260 HsRecConstr c fields -> mapP checkField fields `thenP` \fields ->
261 returnP (HsRecConstr c fields)
262 HsRecUpdate e fields -> mapP checkField fields `thenP` \fields ->
263 checkExpr e `thenP` \e ->
264 returnP (HsRecUpdate e fields)
265 HsEnumFrom e -> check1Expr e HsEnumFrom
266 HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo
267 HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen
268 HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo
269 HsListComp e stmts -> mapP checkStmt stmts `thenP` \stmts ->
270 checkExpr e `thenP` \e ->
271 returnP (HsListComp e stmts)
272 RdrNameHsExprTypeSig loc e ty -> checkExpr e `thenP` \e ->
273 returnP (RdrNameHsExprTypeSig loc e ty)
274 _ -> parseError "parse error in expression"
276 -- type signature for polymorphic recursion!!
277 check1Expr :: RdrNameHsExpr -> (RdrNameHsExpr -> a) -> P a
278 check1Expr e f = checkExpr e `thenP` (returnP . f)
280 check2Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
281 check2Exprs e1 e2 f =
282 checkExpr e1 `thenP` \e1 ->
283 checkExpr e2 `thenP` \e2 ->
286 check3Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
287 check3Exprs e1 e2 e3 f =
288 checkExpr e1 `thenP` \e1 ->
289 checkExpr e2 `thenP` \e2 ->
290 checkExpr e3 `thenP` \e3 ->
293 checkManyExprs es f =
294 mapP checkExpr es `thenP` \es ->
297 checkAlt (HsAlt loc p galts bs)
298 = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs)
300 checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt
301 checkGAlts (HsGuardedAlts galts)
302 = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts)
304 checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc)
306 checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p)
307 checkStmt (HsQualifier e) = check1Expr e HsQualifier
308 checkStmt s@(HsLetStmt bs) = returnP s
310 checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
311 checkField e = returnP e
313 ---------------------------------------------------------------------------
314 -- Check Equation Syntax
318 -> Maybe RdrNameHsType
321 -> P RdrNameMonoBinds
323 checkValDef lhs opt_sig grhss loc
324 = case isFunLhs lhs [] of
326 checkPatterns es `thenP` \ps ->
327 returnP (FunMonoBind f inf [Match [] ps opt_sig grhss] loc)
330 checkPattern lhs `thenP` \lhs ->
331 returnP (PatMonoBind lhs grhss loc)
333 -- A variable binding is parsed as an RdrNamePatBind.
335 isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
336 = Just (op, True, (l:r:es))
337 isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f)
339 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
340 isFunLhs (HsPar e) es = isFunLhs e es
341 isFunLhs _ _ = Nothing
343 ---------------------------------------------------------------------------
344 -- Miscellaneous utilities
346 checkPrec :: Integer -> P ()
347 checkPrec i | 0 <= i && i <= 9 = returnP ()
348 | otherwise = parseError "precedence out of range"
352 -> RdrNameHsRecordBinds
355 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
356 = returnP (RecordCon c fs)
357 mkRecConstrOrUpdate exp fs@(_:_)
358 = returnP (RecordUpd exp fs)
359 mkRecConstrOrUpdate _ _
360 = parseError "Empty record update"
362 -- supplying the ext_name in a foreign decl is optional ; if it
363 -- isn't there, the Haskell name is assumed. Note that no transformation
364 -- of the Haskell name is then performed, so if you foreign export (++),
365 -- it's external name will be "++". Too bad.
366 mkExtName :: Maybe ExtName -> RdrName -> ExtName
367 mkExtName Nothing rdrNm = ExtName (occNameFS (rdrNameOcc rdrNm)) Nothing
368 mkExtName (Just x) _ = x
370 -----------------------------------------------------------------------------
371 -- group function bindings into equation groups
373 -- we assume the bindings are coming in reverse order, so we take the srcloc
374 -- from the *last* binding in the group as the srcloc for the whole group.
376 groupBindings :: [RdrBinding] -> RdrBinding
377 groupBindings binds = group Nothing binds
378 where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
379 group (Just bind) [] = RdrValBinding bind
380 group Nothing [] = RdrNullBind
381 group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
382 (RdrValBinding (FunMonoBind f' _ [mtch] loc) : binds)
383 | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
385 group (Just so_far) binds
386 = RdrValBinding so_far `RdrAndBindings` group Nothing binds
387 group Nothing (bind:binds)
389 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
390 other -> bind `RdrAndBindings` group Nothing binds
392 -----------------------------------------------------------------------------
395 unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
396 tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName
397 ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName
400 | opt_NoImplicitPrelude = mkSrcUnqual dataName unitName
401 | otherwise = mkPreludeQual dataName pRELUDE_Name unitName
404 | opt_NoImplicitPrelude = mkSrcUnqual tcName unitName
405 | otherwise = mkPreludeQual tcName pRELUDE_Name unitName
408 | opt_NoImplicitPrelude = mkSrcUnqual dataName listName
409 | otherwise = mkPreludeQual dataName pRELUDE_Name listName
412 | opt_NoImplicitPrelude = mkSrcUnqual tcName listName
413 | otherwise = mkPreludeQual tcName pRELUDE_Name listName
416 | opt_NoImplicitPrelude = mkSrcUnqual tcName funName
417 | otherwise = mkPreludeQual tcName pRELUDE_Name funName
420 | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr arity))
421 | otherwise = mkPreludeQual dataName pRELUDE_Name
422 (snd (mkTupNameStr arity))
425 | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity))
426 | otherwise = mkPreludeQual tcName pRELUDE_Name
427 (snd (mkTupNameStr arity))
430 ubxTupleCon_RDR arity
431 | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity))
432 | otherwise = mkPreludeQual dataName pRELUDE_Name
433 (snd (mkUbxTupNameStr arity))
435 ubxTupleTyCon_RDR arity
436 | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity))
437 | otherwise = mkPreludeQual tcName pRELUDE_Name
438 (snd (mkUbxTupNameStr arity))
440 unitName = SLIT("()")
441 funName = SLIT("(->)")
442 listName = SLIT("[]")
445 hidingName = SLIT("hiding")
446 qualifiedName = SLIT("qualified")
447 forallName = SLIT("forall")
448 exportName = SLIT("export")
449 labelName = SLIT("label")
450 dynamicName = SLIT("dynamic")
451 unsafeName = SLIT("unsafe")
452 stdcallName = SLIT("stdcall")
453 ccallName = SLIT("ccall")
455 as_var_RDR = mkSrcUnqual varName asName
456 hiding_var_RDR = mkSrcUnqual varName hidingName
457 qualified_var_RDR = mkSrcUnqual varName qualifiedName
458 forall_var_RDR = mkSrcUnqual varName forallName
459 export_var_RDR = mkSrcUnqual varName exportName
460 label_var_RDR = mkSrcUnqual varName labelName
461 dynamic_var_RDR = mkSrcUnqual varName dynamicName
462 unsafe_var_RDR = mkSrcUnqual varName unsafeName
463 stdcall_var_RDR = mkSrcUnqual varName stdcallName
464 ccall_var_RDR = mkSrcUnqual varName ccallName
466 as_tyvar_RDR = mkSrcUnqual tvName asName
467 hiding_tyvar_RDR = mkSrcUnqual tvName hidingName
468 qualified_tyvar_RDR = mkSrcUnqual tvName qualifiedName
469 export_tyvar_RDR = mkSrcUnqual tvName exportName
470 label_tyvar_RDR = mkSrcUnqual tvName labelName
471 dynamic_tyvar_RDR = mkSrcUnqual tvName dynamicName
472 unsafe_tyvar_RDR = mkSrcUnqual tvName unsafeName
473 stdcall_tyvar_RDR = mkSrcUnqual tvName stdcallName
474 ccall_tyvar_RDR = mkSrcUnqual tvName ccallName
476 minus_RDR = mkSrcUnqual varName SLIT("-")
477 pling_RDR = mkSrcUnqual varName SLIT("!")
478 dot_RDR = mkSrcUnqual varName SLIT(".")
480 plus_RDR = mkSrcUnqual varName SLIT("+")