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
28 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
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
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
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
45 , minus_RDR, pling_RDR, dot_RDR
49 #include "HsVersions.h"
57 import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
58 import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString )
59 import CmdLineOpts ( opt_NoImplicitPrelude )
60 import StringBuffer ( lexemeToString )
61 import FastString ( unpackFS )
63 import UniqFM ( UniqFM, listToUFM, lookupUFM )
66 -----------------------------------------------------------------------------
69 parseError :: String -> P a
71 getSrcLocP `thenP` \ loc ->
72 failMsgP (hcat [ppr loc, text ": ", text s])
74 cbot = panic "CCall:result_ty"
76 -----------------------------------------------------------------------------
79 -- When parsing data declarations, we sometimes inadvertently parse
80 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
81 -- This function splits up the type application, adds any pending
82 -- arguments, and converts the type constructor back into a data constructor.
84 splitForConApp :: RdrNameHsType -> [RdrNameBangType]
85 -> P (RdrName, [RdrNameBangType])
87 splitForConApp t ts = split t ts
89 split (MonoTyApp t u) ts = split t (Unbanged u : ts)
91 split (MonoTyVar t) ts = returnP (con, ts)
92 where t_occ = rdrNameOcc t
93 con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
95 split _ _ = parseError "Illegal data/newtype declaration"
97 ----------------------------------------------------------------------------
98 -- Various Syntactic Checks
100 callConvFM :: UniqFM CallConv
101 callConvFM = listToUFM $
102 map (\ (x,y) -> (_PK_ x,y))
103 [ ("stdcall", stdCallConv),
105 -- ("pascal", pascalCallConv),
106 -- ("fastcall", fastCallConv)
109 checkCallConv :: FAST_STRING -> P CallConv
111 case lookupUFM callConvFM s of
112 Nothing -> parseError ("unknown calling convention: `"
113 ++ unpackFS s ++ "'")
114 Just conv -> returnP conv
116 checkInstType :: RdrNameHsType -> P RdrNameHsType
119 HsForAllTy tvs ctxt ty ->
120 checkAssertion ty [] `thenP` \(c,ts)->
121 returnP (HsForAllTy tvs ctxt (MonoDictTy c ts))
123 ty -> checkAssertion ty [] `thenP` \(c,ts)->
124 returnP (HsForAllTy Nothing [] (MonoDictTy c ts))
126 checkContext :: RdrNameHsType -> P RdrNameContext
127 checkContext (MonoTupleTy ts True)
128 = mapP (\t -> checkPred t []) ts `thenP` \ps ->
130 checkContext (MonoTyVar t) -- empty contexts are allowed
131 | t == unitTyCon_RDR = returnP []
133 = checkPred t [] `thenP` \p ->
136 checkPred :: RdrNameHsType -> [RdrNameHsType]
137 -> P (HsPred RdrName)
138 checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
139 = returnP (HsPClass t args)
140 checkPred (MonoTyApp l r) args = checkPred l (r:args)
141 checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty)
142 checkPred _ _ = parseError "Illegal class assertion"
144 checkAssertion :: RdrNameHsType -> [RdrNameHsType]
145 -> P (HsClassAssertion RdrName)
146 checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
148 checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
149 checkAssertion _ _ = parseError "Illegal class assertion"
151 checkDataHeader :: RdrNameHsType
152 -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
153 checkDataHeader (HsForAllTy Nothing cs t) =
154 checkSimple t [] `thenP` \(c,ts) ->
155 returnP (cs,c,map UserTyVar ts)
157 checkSimple t [] `thenP` \(c,ts) ->
158 returnP ([],c,map UserTyVar ts)
160 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
161 checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a
162 = checkSimple l (a:xs)
163 checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
164 checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
166 ---------------------------------------------------------------------------
167 -- Checking Patterns.
169 -- We parse patterns as expressions and check for valid patterns below,
170 -- nverting the expression into a pattern at the same time.
172 checkPattern :: RdrNameHsExpr -> P RdrNamePat
173 checkPattern e = checkPat e []
175 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
176 checkPatterns es = mapP checkPattern es
178 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
179 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
180 checkPat (HsApp f x) args =
181 checkPat x [] `thenP` \x ->
183 checkPat e [] = case e of
184 EWildPat -> returnP WildPatIn
185 HsVar x -> returnP (VarPatIn x)
186 HsLit l -> returnP (LitPatIn l)
187 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
188 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
189 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
190 -- pattern signatures are parsed as sigtypes,
191 -- but they aren't explicit forall points. Hence
192 -- we have to remove the implicit forall here.
194 HsForAllTy Nothing [] ty -> ty
197 returnP (SigPatIn e t')
199 OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR
200 -> returnP (NPlusKPatIn n k)
202 OpApp l op fix r -> checkPat l [] `thenP` \l ->
203 checkPat r [] `thenP` \r ->
205 HsVar c -> returnP (ConOpPatIn l c fix r)
208 NegApp l r -> checkPat l [] `thenP` (returnP . NegPatIn)
209 HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
210 ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
211 returnP (ListPatIn ps)
212 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
213 returnP (TuplePatIn ps b)
214 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
215 returnP (RecPatIn c fs)
218 checkPat _ _ = patFail
220 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
221 -> P (RdrName, RdrNamePat, Bool)
222 checkPatField (n,e,b) =
223 checkPat e [] `thenP` \p ->
226 patFail = parseError "Parse error in pattern"
228 ---------------------------------------------------------------------------
229 -- Check Expression Syntax
232 We can get away without checkExpr if the renamer generates errors for
233 pattern syntax used in expressions (wildcards, as patterns and lazy
236 checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr
237 checkExpr e = case e of
239 HsIPVar _ -> returnP e
241 HsLam match -> checkMatch match `thenP` (returnP.HsLam)
242 HsApp e1 e2 -> check2Exprs e1 e2 HsApp
243 OpApp e1 e2 fix e3 -> checkExpr e1 `thenP` \e1 ->
244 checkExpr e2 `thenP` \e2 ->
245 checkExpr e3 `thenP` \e3 ->
246 returnP (OpApp e1 e2 fix e3)
247 NegApp e neg -> checkExpr e `thenP` \e ->
248 returnP (NegApp e neg)
249 HsPar e -> check1Expr e HsPar
250 SectionL e1 e2 -> check2Exprs e1 e2 SectionL
251 SectionR e1 e2 -> check2Exprs e1 e2 SectionR
252 HsCase e alts -> mapP checkMatch alts `thenP` \alts ->
253 checkExpr e `thenP` \e ->
254 returnP (HsCase e alts)
255 HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf
257 HsLet bs e -> check1Expr e (HsLet bs)
258 HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo)
259 HsTuple es -> checkManyExprs es HsTuple
260 HsList es -> checkManyExprs es HsList
261 HsRecConstr c fields -> mapP checkField fields `thenP` \fields ->
262 returnP (HsRecConstr c fields)
263 HsRecUpdate e fields -> mapP checkField fields `thenP` \fields ->
264 checkExpr e `thenP` \e ->
265 returnP (HsRecUpdate e fields)
266 HsEnumFrom e -> check1Expr e HsEnumFrom
267 HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo
268 HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen
269 HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo
270 HsListComp e stmts -> mapP checkStmt stmts `thenP` \stmts ->
271 checkExpr e `thenP` \e ->
272 returnP (HsListComp e stmts)
273 RdrNameHsExprTypeSig loc e ty -> checkExpr e `thenP` \e ->
274 returnP (RdrNameHsExprTypeSig loc e ty)
275 _ -> parseError "parse error in expression"
277 -- type signature for polymorphic recursion!!
278 check1Expr :: RdrNameHsExpr -> (RdrNameHsExpr -> a) -> P a
279 check1Expr e f = checkExpr e `thenP` (returnP . f)
281 check2Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
282 check2Exprs e1 e2 f =
283 checkExpr e1 `thenP` \e1 ->
284 checkExpr e2 `thenP` \e2 ->
287 check3Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a
288 check3Exprs e1 e2 e3 f =
289 checkExpr e1 `thenP` \e1 ->
290 checkExpr e2 `thenP` \e2 ->
291 checkExpr e3 `thenP` \e3 ->
294 checkManyExprs es f =
295 mapP checkExpr es `thenP` \es ->
298 checkAlt (HsAlt loc p galts bs)
299 = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs)
301 checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt
302 checkGAlts (HsGuardedAlts galts)
303 = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts)
305 checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc)
307 checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p)
308 checkStmt (HsQualifier e) = check1Expr e HsQualifier
309 checkStmt s@(HsLetStmt bs) = returnP s
311 checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
312 checkField e = returnP e
314 ---------------------------------------------------------------------------
315 -- Check Equation Syntax
319 -> Maybe RdrNameHsType
324 checkValDef lhs opt_sig grhss loc
325 = case isFunLhs lhs [] of
327 checkPatterns es `thenP` \ps ->
328 returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
331 checkPattern lhs `thenP` \lhs ->
332 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
339 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
340 checkValSig other ty loc = parseError "Type signature given for an expression"
343 -- A variable binding is parsed as an RdrNamePatBind.
345 isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
346 = Just (op, True, (l:r:es))
347 isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f)
349 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
350 isFunLhs (HsPar e) es = isFunLhs e es
351 isFunLhs _ _ = Nothing
353 ---------------------------------------------------------------------------
354 -- Miscellaneous utilities
356 checkPrec :: Integer -> P ()
357 checkPrec i | 0 <= i && i <= 9 = returnP ()
358 | otherwise = parseError "precedence out of range"
362 -> RdrNameHsRecordBinds
365 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
366 = returnP (RecordCon c fs)
367 mkRecConstrOrUpdate exp fs@(_:_)
368 = returnP (RecordUpd exp fs)
369 mkRecConstrOrUpdate _ _
370 = parseError "Empty record update"
372 -- Supplying the ext_name in a foreign decl is optional ; if it
373 -- isn't there, the Haskell name is assumed. Note that no transformation
374 -- of the Haskell name is then performed, so if you foreign export (++),
375 -- it's external name will be "++". Too bad; it's important because we don't
376 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
377 -- (This is why we use occNameUserString.)
378 mkExtName :: Maybe ExtName -> RdrName -> ExtName
379 mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
381 mkExtName (Just x) _ = x
383 -----------------------------------------------------------------------------
384 -- group function bindings into equation groups
386 -- we assume the bindings are coming in reverse order, so we take the srcloc
387 -- from the *last* binding in the group as the srcloc for the whole group.
389 groupBindings :: [RdrBinding] -> RdrBinding
390 groupBindings binds = group Nothing binds
391 where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
392 group (Just bind) [] = RdrValBinding bind
393 group Nothing [] = RdrNullBind
394 group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
395 (RdrValBinding (FunMonoBind f' _ [mtch] loc) : binds)
396 | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
398 group (Just so_far) binds
399 = RdrValBinding so_far `RdrAndBindings` group Nothing binds
400 group Nothing (bind:binds)
402 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
403 other -> bind `RdrAndBindings` group Nothing binds
405 -----------------------------------------------------------------------------
408 unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
409 tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName
410 ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName
413 | opt_NoImplicitPrelude = mkSrcUnqual dataName unitName
414 | otherwise = mkPreludeQual dataName pRELUDE_Name unitName
417 | opt_NoImplicitPrelude = mkSrcUnqual tcName unitName
418 | otherwise = mkPreludeQual tcName pRELUDE_Name unitName
421 | opt_NoImplicitPrelude = mkSrcUnqual dataName listName
422 | otherwise = mkPreludeQual dataName pRELUDE_Name listName
425 | opt_NoImplicitPrelude = mkSrcUnqual tcName listName
426 | otherwise = mkPreludeQual tcName pRELUDE_Name listName
429 | opt_NoImplicitPrelude = mkSrcUnqual tcName funName
430 | otherwise = mkPreludeQual tcName pRELUDE_Name funName
433 | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr arity))
434 | otherwise = mkPreludeQual dataName pRELUDE_Name
435 (snd (mkTupNameStr arity))
438 | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity))
439 | otherwise = mkPreludeQual tcName pRELUDE_Name
440 (snd (mkTupNameStr arity))
443 ubxTupleCon_RDR arity
444 | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity))
445 | otherwise = mkPreludeQual dataName pRELUDE_Name
446 (snd (mkUbxTupNameStr arity))
448 ubxTupleTyCon_RDR arity
449 | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity))
450 | otherwise = mkPreludeQual tcName pRELUDE_Name
451 (snd (mkUbxTupNameStr arity))
453 unitName = SLIT("()")
454 funName = SLIT("(->)")
455 listName = SLIT("[]")
458 hidingName = SLIT("hiding")
459 qualifiedName = SLIT("qualified")
460 forallName = SLIT("forall")
461 exportName = SLIT("export")
462 labelName = SLIT("label")
463 dynamicName = SLIT("dynamic")
464 unsafeName = SLIT("unsafe")
465 stdcallName = SLIT("stdcall")
466 ccallName = SLIT("ccall")
468 as_var_RDR = mkSrcUnqual varName asName
469 hiding_var_RDR = mkSrcUnqual varName hidingName
470 qualified_var_RDR = mkSrcUnqual varName qualifiedName
471 forall_var_RDR = mkSrcUnqual varName forallName
472 export_var_RDR = mkSrcUnqual varName exportName
473 label_var_RDR = mkSrcUnqual varName labelName
474 dynamic_var_RDR = mkSrcUnqual varName dynamicName
475 unsafe_var_RDR = mkSrcUnqual varName unsafeName
476 stdcall_var_RDR = mkSrcUnqual varName stdcallName
477 ccall_var_RDR = mkSrcUnqual varName ccallName
479 as_tyvar_RDR = mkSrcUnqual tvName asName
480 hiding_tyvar_RDR = mkSrcUnqual tvName hidingName
481 qualified_tyvar_RDR = mkSrcUnqual tvName qualifiedName
482 export_tyvar_RDR = mkSrcUnqual tvName exportName
483 label_tyvar_RDR = mkSrcUnqual tvName labelName
484 dynamic_tyvar_RDR = mkSrcUnqual tvName dynamicName
485 unsafe_tyvar_RDR = mkSrcUnqual tvName unsafeName
486 stdcall_tyvar_RDR = mkSrcUnqual tvName stdcallName
487 ccall_tyvar_RDR = mkSrcUnqual tvName ccallName
489 minus_RDR = mkSrcUnqual varName SLIT("-")
490 pling_RDR = mkSrcUnqual varName SLIT("!")
491 dot_RDR = mkSrcUnqual varName SLIT(".")
493 plus_RDR = mkSrcUnqual varName SLIT("+")