2 % (c) The GRASP/AQUA Project, Glasgow University, 1999
4 \section[ParseUtil]{Parser Utilities}
8 parseError -- String -> Pa
10 , mkVanillaCon, mkRecCon,
12 , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
15 , mkExtName -- Maybe ExtName -> RdrName -> ExtName
17 , checkPrec -- String -> P String
18 , checkContext -- HsType -> P HsContext
19 , checkInstType -- HsType -> P HsType
20 , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])
21 , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName]))
22 , checkPattern -- HsExp -> P HsPat
23 , checkPatterns -- [HsExp] -> P [HsPat]
24 -- , checkExpr -- HsExp -> P HsExp
25 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
26 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
29 #include "HsVersions.h"
32 import HsSyn -- Lots of it
34 import RdrHsSyn ( mkNPlusKPatIn, unitTyCon_RDR,
36 RdrNameHsType, RdrNameBangType, RdrNameContext,
37 RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
38 RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
42 import OccName ( dataName, varName, tcClsName,
43 occNameSpace, setOccNameSpace, occNameUserString )
44 import FastString ( unpackFS )
45 import UniqFM ( UniqFM, listToUFM, lookupUFM )
48 -----------------------------------------------------------------------------
51 parseError :: String -> P a
53 getSrcLocP `thenP` \ loc ->
54 failMsgP (hcat [ppr loc, text ": ", text s])
56 cbot = panic "CCall:result_ty"
58 -----------------------------------------------------------------------------
61 -- When parsing data declarations, we sometimes inadvertently parse
62 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
63 -- This function splits up the type application, adds any pending
64 -- arguments, and converts the type constructor back into a data constructor.
66 mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
71 split (HsAppTy t u) ts = split t (Unbanged u : ts)
72 split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
73 returnP (data_con, VanillaCon ts)
74 split _ _ = parseError "Illegal data/newtype declaration"
76 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
78 = tyConToDataCon con `thenP` \ data_con ->
79 returnP (data_con, RecCon fields)
81 tyConToDataCon :: RdrName -> P RdrName
83 | occNameSpace tc_occ == tcClsName
84 = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
86 = parseError (showSDoc (text "not a constructor:" <+> quotes (ppr tc)))
88 tc_occ = rdrNameOcc tc
91 ----------------------------------------------------------------------------
92 -- Various Syntactic Checks
94 callConvFM :: UniqFM CallConv
95 callConvFM = listToUFM $
96 map (\ (x,y) -> (_PK_ x,y))
97 [ ("stdcall", stdCallConv),
99 -- ("pascal", pascalCallConv),
100 -- ("fastcall", fastCallConv)
103 checkCallConv :: FAST_STRING -> P CallConv
105 case lookupUFM callConvFM s of
106 Nothing -> parseError ("unknown calling convention: `"
107 ++ unpackFS s ++ "'")
108 Just conv -> returnP conv
110 checkInstType :: RdrNameHsType -> P RdrNameHsType
113 HsForAllTy tvs ctxt ty ->
114 checkDictTy ty [] `thenP` \ dict_ty ->
115 returnP (HsForAllTy tvs ctxt dict_ty)
117 ty -> checkDictTy ty [] `thenP` \ dict_ty->
118 returnP (HsForAllTy Nothing [] dict_ty)
120 checkContext :: RdrNameHsType -> P RdrNameContext
121 checkContext (HsTupleTy _ ts)
122 = mapP (\t -> checkPred t []) ts `thenP` \ps ->
124 checkContext (HsTyVar t) -- empty contexts are allowed
125 | t == unitTyCon_RDR = returnP []
127 = checkPred t [] `thenP` \p ->
130 checkPred :: RdrNameHsType -> [RdrNameHsType]
131 -> P (HsPred RdrName)
132 checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
133 = returnP (HsPClass t args)
134 checkPred (HsAppTy l r) args = checkPred l (r:args)
135 checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty)
136 checkPred _ _ = parseError "Illegal class assertion"
138 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
139 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
140 = returnP (mkHsDictTy t args)
141 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
142 checkDictTy _ _ = parseError "Illegal class assertion"
144 -- Put more comments!
145 -- Checks that the lhs of a datatype declaration
146 -- is of the form Context => T a b ... z
147 checkDataHeader :: RdrNameHsType
148 -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
150 checkDataHeader (HsForAllTy Nothing cs t) =
151 checkSimple t [] `thenP` \(c,ts) ->
152 returnP (cs,c,map UserTyVar ts)
154 checkSimple t [] `thenP` \(c,ts) ->
155 returnP ([],c,map UserTyVar ts)
157 -- Checks the type part of the lhs of a datatype declaration
158 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
159 checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
160 = checkSimple l (a:xs)
161 checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
163 checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
164 | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
165 = returnP (tycon,[t1,t2])
167 checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"
169 ---------------------------------------------------------------------------
170 -- Checking Patterns.
172 -- We parse patterns as expressions and check for valid patterns below,
173 -- converting the expression into a pattern at the same time.
175 checkPattern :: RdrNameHsExpr -> P RdrNamePat
176 checkPattern e = checkPat e []
178 checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
179 checkPatterns es = mapP checkPattern es
181 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
182 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
183 checkPat (HsApp f x) args =
184 checkPat x [] `thenP` \x ->
186 checkPat e [] = case e of
187 EWildPat -> returnP WildPatIn
188 HsVar x -> returnP (VarPatIn x)
189 HsLit l -> returnP (LitPatIn l)
190 HsOverLit l -> returnP (NPatIn l)
191 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
192 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
193 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
194 -- Pattern signatures are parsed as sigtypes,
195 -- but they aren't explicit forall points. Hence
196 -- we have to remove the implicit forall here.
198 HsForAllTy Nothing [] ty -> ty
201 returnP (SigPatIn e t')
203 OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _))
205 -> returnP (mkNPlusKPatIn n lit)
207 OpApp l op fix r -> checkPat l [] `thenP` \l ->
208 checkPat r [] `thenP` \r ->
210 HsVar c -> returnP (ConOpPatIn l c fix r)
213 HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
214 ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
215 returnP (ListPatIn ps)
217 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
218 returnP (TuplePatIn ps b)
220 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
221 returnP (RecPatIn c fs)
223 HsType ty -> returnP (TypePatIn ty)
226 checkPat _ _ = patFail
228 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
229 -> P (RdrName, RdrNamePat, Bool)
230 checkPatField (n,e,b) =
231 checkPat e [] `thenP` \p ->
234 patFail = parseError "Parse error in pattern"
237 ---------------------------------------------------------------------------
238 -- Check Equation Syntax
242 -> Maybe RdrNameHsType
247 checkValDef lhs opt_sig grhss loc
248 = case isFunLhs lhs [] of
250 checkPatterns es `thenP` \ps ->
251 returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
254 checkPattern lhs `thenP` \lhs ->
255 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
262 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
263 checkValSig other ty loc = parseError "Type signature given for an expression"
266 -- A variable binding is parsed as an RdrNameFunMonoBind.
267 -- See comments with HsBinds.MonoBinds
269 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
270 isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
271 = Just (op, True, (l:r:es))
272 isFunLhs (HsVar f) es | not (isRdrDataCon f)
274 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
275 isFunLhs (HsPar e) es = isFunLhs e es
276 isFunLhs _ _ = Nothing
278 ---------------------------------------------------------------------------
279 -- Miscellaneous utilities
281 checkPrec :: Integer -> P ()
282 checkPrec i | 0 <= i && i <= 9 = returnP ()
283 | otherwise = parseError "precedence out of range"
287 -> RdrNameHsRecordBinds
290 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
291 = returnP (RecordCon c fs)
292 mkRecConstrOrUpdate exp fs@(_:_)
293 = returnP (RecordUpd exp fs)
294 mkRecConstrOrUpdate _ _
295 = parseError "Empty record update"
297 -- Supplying the ext_name in a foreign decl is optional ; if it
298 -- isn't there, the Haskell name is assumed. Note that no transformation
299 -- of the Haskell name is then performed, so if you foreign export (++),
300 -- it's external name will be "++". Too bad; it's important because we don't
301 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
302 -- (This is why we use occNameUserString.)
304 mkExtName :: Maybe ExtName -> RdrName -> ExtName
305 mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
307 mkExtName (Just x) _ = x
309 -----------------------------------------------------------------------------
310 -- group function bindings into equation groups
312 -- we assume the bindings are coming in reverse order, so we take the srcloc
313 -- from the *last* binding in the group as the srcloc for the whole group.
315 groupBindings :: [RdrBinding] -> RdrBinding
316 groupBindings binds = group Nothing binds
317 where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
318 group (Just bind) [] = RdrValBinding bind
319 group Nothing [] = RdrNullBind
321 -- don't group together FunMonoBinds if they have
322 -- no arguments. This is necessary now that variable bindings
323 -- with no arguments are now treated as FunMonoBinds rather
324 -- than pattern bindings (tests/rename/should_fail/rnfail002).
325 group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
326 (RdrValBinding (FunMonoBind f' _
327 [mtch@(Match _ (_:_) _ _)] loc)
329 | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
331 group (Just so_far) binds
332 = RdrValBinding so_far `RdrAndBindings` group Nothing binds
333 group Nothing (bind:binds)
335 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
336 other -> bind `RdrAndBindings` group Nothing binds
338 plus_RDR = mkUnqual varName SLIT("+")