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 , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])
22 , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName]))
23 , checkPattern -- HsExp -> P HsPat
24 , checkPatterns -- [HsExp] -> P [HsPat]
25 -- , checkExpr -- HsExp -> P HsExp
26 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
27 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
30 #include "HsVersions.h"
33 import HsSyn -- Lots of it
35 import RdrHsSyn ( mkNPlusKPatIn, unitTyCon_RDR,
37 RdrNameHsType, RdrNameBangType, RdrNameContext,
38 RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
39 RdrNameHsRecordBinds, RdrNameMonoBinds
43 import OccName ( dataName, varName, tcClsName,
44 occNameSpace, setOccNameSpace, occNameUserString )
45 import FastString ( unpackFS )
46 import UniqFM ( UniqFM, listToUFM, lookupUFM )
49 -----------------------------------------------------------------------------
52 parseError :: String -> P a
54 getSrcLocP `thenP` \ loc ->
55 failMsgP (hcat [ppr loc, text ": ", text s])
57 cbot = panic "CCall:result_ty"
59 -----------------------------------------------------------------------------
62 -- When parsing data declarations, we sometimes inadvertently parse
63 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
64 -- This function splits up the type application, adds any pending
65 -- arguments, and converts the type constructor back into a data constructor.
67 splitForConApp :: RdrNameHsType -> [RdrNameBangType]
68 -> P (RdrName, [RdrNameBangType])
70 splitForConApp t ts = split t ts
72 split (HsAppTy t u) ts = split t (Unbanged u : ts)
73 {- split (HsOpTy t1 t ty2) ts =
74 -- check that we've got a type constructor at the head
75 if occNameSpace t_occ /= tcClsName
77 (showSDoc (text "not a constructor: (type pattern)`" <>
79 else returnP (con, ts)
80 where t_occ = rdrNameOcc t
81 con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
83 split (HsTyVar t) ts =
84 -- check that we've got a type constructor at the head
85 if occNameSpace t_occ /= tcClsName
87 (showSDoc (text "not a constructor: `" <>
89 else returnP (con, ts)
90 where t_occ = rdrNameOcc t
91 con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
93 split _ _ = parseError "Illegal data/newtype declaration"
95 ----------------------------------------------------------------------------
96 -- Various Syntactic Checks
98 callConvFM :: UniqFM CallConv
99 callConvFM = listToUFM $
100 map (\ (x,y) -> (_PK_ x,y))
101 [ ("stdcall", stdCallConv),
103 -- ("pascal", pascalCallConv),
104 -- ("fastcall", fastCallConv)
107 checkCallConv :: FAST_STRING -> P CallConv
109 case lookupUFM callConvFM s of
110 Nothing -> parseError ("unknown calling convention: `"
111 ++ unpackFS s ++ "'")
112 Just conv -> returnP conv
114 checkInstType :: RdrNameHsType -> P RdrNameHsType
117 HsForAllTy tvs ctxt ty ->
118 checkDictTy ty [] `thenP` \ dict_ty ->
119 returnP (HsForAllTy tvs ctxt dict_ty)
121 ty -> checkDictTy ty [] `thenP` \ dict_ty->
122 returnP (HsForAllTy Nothing [] dict_ty)
124 checkContext :: RdrNameHsType -> P RdrNameContext
125 checkContext (HsTupleTy _ ts)
126 = mapP (\t -> checkPred t []) ts `thenP` \ps ->
128 checkContext (HsTyVar t) -- empty contexts are allowed
129 | t == unitTyCon_RDR = returnP []
131 = checkPred t [] `thenP` \p ->
134 checkPred :: RdrNameHsType -> [RdrNameHsType]
135 -> P (HsPred RdrName)
136 checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
137 = returnP (HsPClass t args)
138 checkPred (HsAppTy l r) args = checkPred l (r:args)
139 checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty)
140 checkPred _ _ = parseError "Illegal class assertion"
142 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
143 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
144 = returnP (mkHsDictTy t args)
145 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
146 checkDictTy _ _ = parseError "Illegal class assertion"
148 -- Put more comments!
149 -- Checks that the lhs of a datatype declaration
150 -- is of the form Context => T a b ... z
151 checkDataHeader :: RdrNameHsType
152 -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
154 checkDataHeader (HsForAllTy Nothing cs t) =
155 checkSimple t [] `thenP` \(c,ts) ->
156 returnP (cs,c,map UserTyVar ts)
158 checkSimple t [] `thenP` \(c,ts) ->
159 returnP ([],c,map UserTyVar ts)
161 -- Checks the type part of the lhs of a datatype declaration
162 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
163 checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
164 = checkSimple l (a:xs)
165 checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
167 checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
168 | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
169 = returnP (tycon,[t1,t2])
171 checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"
173 ---------------------------------------------------------------------------
174 -- Checking Patterns.
176 -- We parse patterns as expressions and check for valid patterns below,
177 -- converting the expression into a pattern at the same time.
179 checkPattern :: RdrNameHsExpr -> P RdrNamePat
180 checkPattern e = checkPat e []
182 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
183 checkPatterns es = mapP checkPattern es
185 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
186 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
187 checkPat (HsApp f x) args =
188 checkPat x [] `thenP` \x ->
190 checkPat e [] = case e of
191 EWildPat -> returnP WildPatIn
192 HsVar x -> returnP (VarPatIn x)
193 HsLit l -> returnP (LitPatIn l)
194 HsOverLit l -> returnP (NPatIn l)
195 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
196 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
197 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
198 -- Pattern signatures are parsed as sigtypes,
199 -- but they aren't explicit forall points. Hence
200 -- we have to remove the implicit forall here.
202 HsForAllTy Nothing [] ty -> ty
205 returnP (SigPatIn e t')
207 OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _))
209 -> returnP (mkNPlusKPatIn n lit)
211 OpApp l op fix r -> checkPat l [] `thenP` \l ->
212 checkPat r [] `thenP` \r ->
214 HsVar c -> returnP (ConOpPatIn l c fix r)
217 HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
218 ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
219 returnP (ListPatIn ps)
221 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
222 returnP (TuplePatIn ps b)
224 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
225 returnP (RecPatIn c fs)
227 HsType ty -> returnP (TypePatIn ty)
230 checkPat _ _ = patFail
232 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
233 -> P (RdrName, RdrNamePat, Bool)
234 checkPatField (n,e,b) =
235 checkPat e [] `thenP` \p ->
238 patFail = parseError "Parse error in pattern"
241 ---------------------------------------------------------------------------
242 -- Check Equation Syntax
246 -> Maybe RdrNameHsType
251 checkValDef lhs opt_sig grhss loc
252 = case isFunLhs lhs [] of
254 checkPatterns es `thenP` \ps ->
255 returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
258 checkPattern lhs `thenP` \lhs ->
259 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
266 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
267 checkValSig other ty loc = parseError "Type signature given for an expression"
270 -- A variable binding is parsed as an RdrNameFunMonoBind.
271 -- See comments with HsBinds.MonoBinds
273 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
274 isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
275 = Just (op, True, (l:r:es))
276 isFunLhs (HsVar f) es | not (isRdrDataCon f)
278 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
279 isFunLhs (HsPar e) es = isFunLhs e es
280 isFunLhs _ _ = Nothing
282 ---------------------------------------------------------------------------
283 -- Miscellaneous utilities
285 checkPrec :: Integer -> P ()
286 checkPrec i | 0 <= i && i <= 9 = returnP ()
287 | otherwise = parseError "precedence out of range"
291 -> RdrNameHsRecordBinds
294 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
295 = returnP (RecordCon c fs)
296 mkRecConstrOrUpdate exp fs@(_:_)
297 = returnP (RecordUpd exp fs)
298 mkRecConstrOrUpdate _ _
299 = parseError "Empty record update"
301 -- Supplying the ext_name in a foreign decl is optional ; if it
302 -- isn't there, the Haskell name is assumed. Note that no transformation
303 -- of the Haskell name is then performed, so if you foreign export (++),
304 -- it's external name will be "++". Too bad; it's important because we don't
305 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
306 -- (This is why we use occNameUserString.)
308 mkExtName :: Maybe ExtName -> RdrName -> ExtName
309 mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
311 mkExtName (Just x) _ = x
313 -----------------------------------------------------------------------------
314 -- group function bindings into equation groups
316 -- we assume the bindings are coming in reverse order, so we take the srcloc
317 -- from the *last* binding in the group as the srcloc for the whole group.
319 groupBindings :: [RdrBinding] -> RdrBinding
320 groupBindings binds = group Nothing binds
321 where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
322 group (Just bind) [] = RdrValBinding bind
323 group Nothing [] = RdrNullBind
325 -- don't group together FunMonoBinds if they have
326 -- no arguments. This is necessary now that variable bindings
327 -- with no arguments are now treated as FunMonoBinds rather
328 -- than pattern bindings (tests/rename/should_fail/rnfail002).
329 group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
330 (RdrValBinding (FunMonoBind f' _
331 [mtch@(Match _ (_:_) _ _)] loc)
333 | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
335 group (Just so_far) binds
336 = RdrValBinding so_far `RdrAndBindings` group Nothing binds
337 group Nothing (bind:binds)
339 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
340 other -> bind `RdrAndBindings` group Nothing binds
342 plus_RDR = mkSrcUnqual varName SLIT("+")