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 , mkIfaceExports -- :: [RdrNameTyClDecl] -> [RdrExportItem]
17 , mkImport -- CallConv -> Safety
18 -- -> (FastString, RdrName, RdrNameHsType)
21 , mkExport -- CallConv
22 -- -> (FastString, RdrName, RdrNameHsType)
25 , mkExtName -- RdrName -> CLabelString
27 , checkPrec -- String -> P String
28 , checkContext -- HsType -> P HsContext
29 , checkPred -- HsType -> P HsPred
30 , checkTyVars -- [HsTyVar] -> P [HsType]
31 , checkInstType -- HsType -> P HsType
32 , checkPattern -- HsExp -> P HsPat
33 , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
34 , checkDo -- [Stmt] -> P [Stmt]
35 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
36 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
39 #include "HsVersions.h"
41 import List ( isSuffixOf )
44 import HscTypes ( RdrAvailInfo, GenAvailInfo(..) )
45 import HsSyn -- Lots of it
46 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
51 import PrelNames ( unitTyCon_RDR )
52 import OccName ( dataName, varName, tcClsName, isDataOcc,
53 occNameSpace, setOccNameSpace, occNameUserString )
54 import CStrings ( CLabelString )
58 -----------------------------------------------------------------------------
61 parseError :: String -> P a
63 getSrcLocP `thenP` \ loc ->
64 failMsgP (hcat [ppr loc, text ": ", text s])
67 -----------------------------------------------------------------------------
70 -- When parsing data declarations, we sometimes inadvertently parse
71 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
72 -- This function splits up the type application, adds any pending
73 -- arguments, and converts the type constructor back into a data constructor.
75 mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
80 split (HsAppTy t u) ts = split t (unbangedType u : ts)
81 split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
82 returnP (data_con, VanillaCon ts)
83 split _ _ = parseError "Illegal data/newtype declaration"
85 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
87 = tyConToDataCon con `thenP` \ data_con ->
88 returnP (data_con, RecCon fields)
90 tyConToDataCon :: RdrName -> P RdrName
92 | occNameSpace tc_occ == tcClsName
93 = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
95 = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
97 tc_occ = rdrNameOcc tc
100 ----------------------------------------------------------------------------
101 -- Various Syntactic Checks
103 checkInstType :: RdrNameHsType -> P RdrNameHsType
106 HsForAllTy tvs ctxt ty ->
107 checkDictTy ty [] `thenP` \ dict_ty ->
108 returnP (HsForAllTy tvs ctxt dict_ty)
110 ty -> checkDictTy ty [] `thenP` \ dict_ty->
111 returnP (HsForAllTy Nothing [] dict_ty)
113 checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
114 checkTyVars tvs = mapP chk tvs
116 chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k)
117 chk (HsTyVar tv) = returnP (UserTyVar tv)
118 chk other = parseError "Type found where type variable expected"
120 checkContext :: RdrNameHsType -> P RdrNameContext
121 checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
124 checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
125 | t == unitTyCon_RDR = returnP []
128 = checkPred t `thenP` \p ->
131 checkPred :: RdrNameHsType -> P (HsPred RdrName)
132 -- Watch out.. in ...deriving( Show )... we use checkPred on
133 -- the list of partially applied predicates in the deriving,
134 -- so there can be zero args.
135 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
139 go (HsTyVar t) args | not (isRdrTyVar t)
140 = returnP (HsClassP t args)
141 go (HsAppTy l r) args = go l (r:args)
142 go _ _ = parseError "Illegal class assertion"
144 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
145 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
146 = returnP (mkHsDictTy t args)
147 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
148 checkDictTy _ _ = parseError "Malformed context in instance header"
151 ---------------------------------------------------------------------------
152 -- Checking statements in a do-expression
153 -- We parse do { e1 ; e2 ; }
154 -- as [ExprStmt e1, ExprStmt e2]
155 -- checkDo (a) checks that the last thing is an ExprStmt
156 -- (b) transforms it to a ResultStmt
158 checkDo [] = parseError "Empty 'do' construct"
159 checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
160 checkDo [s] = parseError "The last statement in a 'do' construct must be an expression"
161 checkDo (s:ss) = checkDo ss `thenP` \ ss' ->
164 ---------------------------------------------------------------------------
165 -- Checking Patterns.
167 -- We parse patterns as expressions and check for valid patterns below,
168 -- converting the expression into a pattern at the same time.
170 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
171 checkPattern loc e = setSrcLocP loc (checkPat e [])
173 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
174 checkPatterns loc es = mapP (checkPattern loc) es
176 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
177 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
178 checkPat (HsApp f x) args =
179 checkPat x [] `thenP` \x ->
181 checkPat e [] = case e of
182 EWildPat -> returnP WildPatIn
183 HsVar x -> returnP (VarPatIn x)
184 HsLit l -> returnP (LitPatIn l)
185 HsOverLit l -> returnP (NPatIn 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 -- translate out NegApps of literals in patterns.
199 -- NB. negative primitive literals are already handled by
200 -- RdrHsSyn.mkHsNegApp
201 NegApp (HsOverLit (HsIntegral i n)) _
202 -> returnP (NPatIn (HsIntegral (-i) n))
203 NegApp (HsOverLit (HsFractional f n)) _
204 -> returnP (NPatIn (HsFractional (-f) n))
206 OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
208 -> returnP (mkNPlusKPat n lit)
210 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
212 OpApp l op fix r -> checkPat l [] `thenP` \l ->
213 checkPat r [] `thenP` \r ->
215 HsVar c | isDataOcc (rdrNameOcc c)
216 -> returnP (ConOpPatIn l c fix r)
219 HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
220 ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
221 returnP (ListPatIn ps)
222 ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
223 returnP (PArrPatIn ps)
225 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
226 returnP (TuplePatIn ps b)
228 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
229 returnP (RecPatIn c fs)
231 HsType ty -> returnP (TypePatIn ty)
234 checkPat _ _ = patFail
236 checkPatField :: (RdrName, RdrNameHsExpr, Bool)
237 -> P (RdrName, RdrNamePat, Bool)
238 checkPatField (n,e,b) =
239 checkPat e [] `thenP` \p ->
242 patFail = parseError "Parse error in pattern"
245 ---------------------------------------------------------------------------
246 -- Check Equation Syntax
250 -> Maybe RdrNameHsType
255 checkValDef lhs opt_sig grhss loc
256 = case isFunLhs lhs [] of
258 checkPatterns loc es `thenP` \ps ->
259 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
262 checkPattern loc lhs `thenP` \lhs ->
263 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
270 checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
271 checkValSig other ty loc = parseError "Type signature given for an expression"
274 -- A variable binding is parsed as an RdrNameFunMonoBind.
275 -- See comments with HsBinds.MonoBinds
277 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
278 isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
279 = Just (op, True, (l:r:es))
281 = case isFunLhs l es of
282 Just (op', True, j : k : es') ->
283 Just (op', True, j : OpApp k (HsVar op) fix r : es')
285 isFunLhs (HsVar f) es | not (isRdrDataCon f)
287 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
288 isFunLhs (HsPar e) es@(_:_) = isFunLhs e es
289 isFunLhs _ _ = Nothing
291 ---------------------------------------------------------------------------
292 -- Miscellaneous utilities
294 checkPrec :: Integer -> P ()
295 checkPrec i | 0 <= i && i <= 9 = returnP ()
296 | otherwise = parseError "Precedence out of range"
300 -> RdrNameHsRecordBinds
303 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
304 = returnP (RecordCon c fs)
305 mkRecConstrOrUpdate exp fs@(_:_)
306 = returnP (RecordUpd exp fs)
307 mkRecConstrOrUpdate _ _
308 = parseError "Empty record update"
310 -----------------------------------------------------------------------------
311 -- utilities for foreign declarations
313 -- supported calling conventions
315 data CallConv = CCall CCallConv -- ccall or stdcall
318 -- construct a foreign import declaration
322 -> (FastString, RdrName, RdrNameHsType)
325 mkImport (CCall cconv) safety (entity, v, ty) loc =
326 parseCImport entity cconv safety v `thenP` \importSpec ->
327 returnP $ ForD (ForeignImport v ty importSpec False loc)
328 mkImport (DNCall ) _ (entity, v, ty) loc =
329 returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
331 -- parse the entity string of a foreign import declaration for the `ccall' or
332 -- `stdcall' calling convention'
334 parseCImport :: FastString
339 parseCImport entity cconv safety v
340 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
341 | entity == FSLIT ("dynamic") =
342 returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
343 | entity == FSLIT ("wrapper") =
344 returnP $ CImport cconv safety nilFS nilFS CWrapper
345 | otherwise = parse0 (unpackFS entity)
347 -- using the static keyword?
348 parse0 (' ': rest) = parse0 rest
349 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
350 parse0 rest = parse1 rest
351 -- check for header file name
352 parse1 "" = parse4 "" nilFS False nilFS
353 parse1 (' ':rest) = parse1 rest
354 parse1 str@('&':_ ) = parse2 str nilFS
355 parse1 str@('[':_ ) = parse3 str nilFS False
357 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
358 | otherwise = parse4 str nilFS False nilFS
360 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
361 -- check for address operator (indicating a label import)
362 parse2 "" header = parse4 "" header False nilFS
363 parse2 (' ':rest) header = parse2 rest header
364 parse2 ('&':rest) header = parse3 rest header True
365 parse2 str@('[':_ ) header = parse3 str header False
366 parse2 str header = parse4 str header False nilFS
367 -- check for library object name
368 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
369 parse3 ('[':rest) header isLbl =
370 case break (== ']') rest of
371 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
372 _ -> parseError "Missing ']' in entity"
373 parse3 str header isLbl = parse4 str header isLbl nilFS
374 -- check for name of C function
375 parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib
376 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
377 parse4 str header isLbl lib
378 | all (== ' ') rest = build (mkFastString first) header isLbl lib
379 | otherwise = parseError "Malformed entity string"
381 (first, rest) = break (== ' ') str
383 build cid header False lib = returnP $
384 CImport cconv safety header lib (CFunction (StaticTarget cid))
385 build cid header True lib = returnP $
386 CImport cconv safety header lib (CLabel cid )
388 -- construct a foreign export declaration
391 -> (FastString, RdrName, RdrNameHsType)
394 mkExport (CCall cconv) (entity, v, ty) loc = returnP $
395 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
397 entity' | nullFastString entity = mkExtName v
399 mkExport DNCall (entity, v, ty) loc =
400 parseError "Foreign export is not yet supported for .NET"
402 -- Supplying the ext_name in a foreign decl is optional; if it
403 -- isn't there, the Haskell name is assumed. Note that no transformation
404 -- of the Haskell name is then performed, so if you foreign export (++),
405 -- it's external name will be "++". Too bad; it's important because we don't
406 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
407 -- (This is why we use occNameUserString.)
409 mkExtName :: RdrName -> CLabelString
410 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
412 -----------------------------------------------------------------------------
413 -- group function bindings into equation groups
415 -- we assume the bindings are coming in reverse order, so we take the srcloc
416 -- from the *last* binding in the group as the srcloc for the whole group.
418 groupBindings :: [RdrBinding] -> RdrBinding
419 groupBindings binds = group Nothing binds
420 where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
421 group (Just bind) [] = RdrValBinding bind
422 group Nothing [] = RdrNullBind
424 -- don't group together FunMonoBinds if they have
425 -- no arguments. This is necessary now that variable bindings
426 -- with no arguments are now treated as FunMonoBinds rather
427 -- than pattern bindings (tests/rename/should_fail/rnfail002).
428 group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
429 (RdrValBinding (FunMonoBind f' _
430 [mtch@(Match (_:_) _ _)] loc)
432 | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
434 group (Just so_far) binds
435 = RdrValBinding so_far `RdrAndBindings` group Nothing binds
436 group Nothing (bind:binds)
438 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
439 other -> bind `RdrAndBindings` group Nothing binds
441 -- ---------------------------------------------------------------------------
442 -- Make the export list for an interface
444 mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
445 mkIfaceExports decls = map getExport decls
446 where getExport d = case d of
447 TyData{} -> tc_export
448 ClassDecl{} -> tc_export
451 tc_export = AvailTC (rdrNameOcc (tcdName d))
452 (map (rdrNameOcc.fst) (tyClDeclNames d))
453 var_export = Avail (rdrNameOcc (tcdName d))