2 % (c) The GRASP/AQUA Project, Glasgow University, 1999
4 \section[ParseUtil]{Parser Utilities}
8 parseError -- String -> Pa
9 , mkVanillaCon, mkRecCon,
11 , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
14 , mkExtName -- RdrName -> ExtName
16 , checkPrec -- String -> P String
17 , checkContext -- HsType -> P HsContext
18 , checkInstType -- HsType -> P HsType
19 , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])
20 , checkPattern -- HsExp -> P HsPat
21 , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
22 , checkDo -- [Stmt] -> P [Stmt]
23 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
24 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
27 #include "HsVersions.h"
30 import HsSyn -- Lots of it
32 import RdrHsSyn ( RdrBinding(..),
33 RdrNameHsType, RdrNameBangType, RdrNameContext,
34 RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
35 RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails,
39 import PrelNames ( unitTyCon_RDR )
40 import OccName ( dataName, varName, tcClsName,
41 occNameSpace, setOccNameSpace, occNameUserString )
42 import CStrings ( CLabelString )
43 import FastString ( unpackFS )
46 -----------------------------------------------------------------------------
49 parseError :: String -> P a
51 getSrcLocP `thenP` \ loc ->
52 failMsgP (hcat [ppr loc, text ": ", text s])
55 -----------------------------------------------------------------------------
58 -- When parsing data declarations, we sometimes inadvertently parse
59 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
60 -- This function splits up the type application, adds any pending
61 -- arguments, and converts the type constructor back into a data constructor.
63 mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
68 split (HsAppTy t u) ts = split t (unbangedType u : ts)
69 split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
70 returnP (data_con, VanillaCon ts)
71 split _ _ = parseError "Illegal data/newtype declaration"
73 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
75 = tyConToDataCon con `thenP` \ data_con ->
76 returnP (data_con, RecCon fields)
78 tyConToDataCon :: RdrName -> P RdrName
80 | occNameSpace tc_occ == tcClsName
81 = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
83 = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
85 tc_occ = rdrNameOcc tc
88 ----------------------------------------------------------------------------
89 -- Various Syntactic Checks
91 checkInstType :: RdrNameHsType -> P RdrNameHsType
94 HsForAllTy tvs ctxt ty ->
95 checkDictTy ty [] `thenP` \ dict_ty ->
96 returnP (HsForAllTy tvs ctxt dict_ty)
98 ty -> checkDictTy ty [] `thenP` \ dict_ty->
99 returnP (HsForAllTy Nothing [] dict_ty)
101 checkContext :: RdrNameHsType -> P RdrNameContext
102 checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
103 = mapP (\t -> checkPred t []) ts `thenP` \ps ->
106 checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
107 | t == unitTyCon_RDR = returnP []
110 = checkPred t [] `thenP` \p ->
113 checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName)
114 checkPred (HsTyVar t) args | not (isRdrTyVar t)
115 = returnP (HsClassP t args)
116 checkPred (HsAppTy l r) args = checkPred l (r:args)
117 checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty)
118 checkPred _ _ = parseError "Illegal class assertion"
120 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
121 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
122 = returnP (mkHsDictTy t args)
123 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
124 checkDictTy _ _ = parseError "Malformed context in instance header"
126 -- Put more comments!
127 -- Checks that the lhs of a datatype declaration
128 -- is of the form Context => T a b ... z
129 checkDataHeader :: String -- data/newtype/class
131 -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
133 checkDataHeader s (HsForAllTy Nothing cs t) =
134 checkSimple s t [] `thenP` \(c,ts) ->
135 returnP (cs,c,map UserTyVar ts)
136 checkDataHeader s t =
137 checkSimple s t [] `thenP` \(c,ts) ->
138 returnP ([],c,map UserTyVar ts)
140 -- Checks the type part of the lhs of
141 -- a data/newtype/class declaration
142 checkSimple :: String -> RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
143 checkSimple s (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
144 = checkSimple s l (a:xs)
145 checkSimple s (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
147 checkSimple s (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
148 | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
149 = returnP (tycon,[t1,t2])
151 checkSimple s t _ = parseError ("Malformed " ++ s ++ " declaration")
153 ---------------------------------------------------------------------------
154 -- Checking statements in a do-expression
155 -- We parse do { e1 ; e2 ; }
156 -- as [ExprStmt e1, ExprStmt e2]
157 -- checkDo (a) checks that the last thing is an ExprStmt
158 -- (b) transforms it to a ResultStmt
160 checkDo [] = parseError "Empty 'do' construct"
161 checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
162 checkDo [s] = parseError "The last statement in a 'do' construct must be an expression"
163 checkDo (s:ss) = checkDo ss `thenP` \ ss' ->
166 ---------------------------------------------------------------------------
167 -- Checking Patterns.
169 -- We parse patterns as expressions and check for valid patterns below,
170 -- converting the expression into a pattern at the same time.
172 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
173 checkPattern loc e = setSrcLocP loc (checkPat e [])
175 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
176 checkPatterns loc es = mapP (checkPattern loc) 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 HsOverLit l -> returnP (NPatIn l)
188 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
189 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
190 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
191 -- Pattern signatures are parsed as sigtypes,
192 -- but they aren't explicit forall points. Hence
193 -- we have to remove the implicit forall here.
195 HsForAllTy Nothing [] ty -> ty
198 returnP (SigPatIn e t')
200 OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
202 -> returnP (mkNPlusKPat n lit)
204 plus_RDR = mkUnqual varName SLIT("+") -- Hack
206 OpApp l op fix r -> checkPat l [] `thenP` \l ->
207 checkPat r [] `thenP` \r ->
209 HsVar c -> returnP (ConOpPatIn l c fix r)
212 HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
213 ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
214 returnP (ListPatIn ps)
216 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
217 returnP (TuplePatIn ps b)
219 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
220 returnP (RecPatIn c fs)
222 HsType ty -> returnP (TypePatIn ty)
225 checkPat _ _ = patFail
227 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
228 -> P (RdrName, RdrNamePat, Bool)
229 checkPatField (n,e,b) =
230 checkPat e [] `thenP` \p ->
233 patFail = parseError "Parse error in pattern"
236 ---------------------------------------------------------------------------
237 -- Check Equation Syntax
241 -> Maybe RdrNameHsType
246 checkValDef lhs opt_sig grhss loc
247 = case isFunLhs lhs [] of
249 checkPatterns loc es `thenP` \ps ->
250 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
253 checkPattern loc lhs `thenP` \lhs ->
254 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
261 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
262 checkValSig other ty loc = parseError "Type signature given for an expression"
265 -- A variable binding is parsed as an RdrNameFunMonoBind.
266 -- See comments with HsBinds.MonoBinds
268 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
269 isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
270 = Just (op, True, (l:r:es))
272 = case isFunLhs l es of
273 Just (op', True, j : k : es') ->
274 Just (op', True, j : OpApp k (HsVar op) fix 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 :: RdrName -> CLabelString
309 mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))
311 -----------------------------------------------------------------------------
312 -- group function bindings into equation groups
314 -- we assume the bindings are coming in reverse order, so we take the srcloc
315 -- from the *last* binding in the group as the srcloc for the whole group.
317 groupBindings :: [RdrBinding] -> RdrBinding
318 groupBindings binds = group Nothing binds
319 where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
320 group (Just bind) [] = RdrValBinding bind
321 group Nothing [] = RdrNullBind
323 -- don't group together FunMonoBinds if they have
324 -- no arguments. This is necessary now that variable bindings
325 -- with no arguments are now treated as FunMonoBinds rather
326 -- than pattern bindings (tests/rename/should_fail/rnfail002).
327 group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
328 (RdrValBinding (FunMonoBind f' _
329 [mtch@(Match (_:_) _ _)] loc)
331 | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
333 group (Just so_far) binds
334 = RdrValBinding so_far `RdrAndBindings` group Nothing binds
335 group Nothing (bind:binds)
337 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
338 other -> bind `RdrAndBindings` group Nothing binds