2 % (c) The GRASP/AQUA Project, Glasgow University, 1999
4 \section[ParseUtil]{Parser Utilities}
8 parseError -- String -> Pa
9 , mkPrefixCon, 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 , checkTyClHdr -- HsType -> (name,[tyvar])
32 , checkInstType -- HsType -> P HsType
33 , checkPattern -- HsExp -> P HsPat
34 , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
35 , checkDo -- [Stmt] -> P [Stmt]
36 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
37 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
40 #include "HsVersions.h"
42 import List ( isSuffixOf )
45 import HscTypes ( RdrAvailInfo, GenAvailInfo(..) )
46 import HsSyn -- Lots of it
47 import TysWiredIn ( unitTyCon )
48 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
53 import OccName ( dataName, varName, isDataOcc, isTcOcc, 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 mkPrefixCon :: 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, PrefixCon 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 [ (l,t) | (ls,t) <- fields, l <- ls ])
90 tyConToDataCon :: RdrName -> P RdrName
92 | isTcOcc (rdrNameOcc tc)
93 = returnP (setRdrNameSpace tc dataName)
95 = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
97 ----------------------------------------------------------------------------
98 -- Various Syntactic Checks
100 checkInstType :: RdrNameHsType -> P RdrNameHsType
103 HsForAllTy tvs ctxt ty ->
104 checkDictTy ty [] `thenP` \ dict_ty ->
105 returnP (HsForAllTy tvs ctxt dict_ty)
107 HsParTy ty -> checkInstType ty
109 ty -> checkDictTy ty [] `thenP` \ dict_ty->
110 returnP (HsForAllTy Nothing [] dict_ty)
112 checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
113 checkTyVars tvs = mapP chk tvs
115 chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k)
116 chk (HsTyVar tv) = returnP (UserTyVar tv)
117 chk other = parseError "Type found where type variable expected"
119 checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
120 -- The header of a type or class decl should look like
121 -- (C a, D b) => T a b
129 | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs ->
131 go (HsOpTy t1 (HsTyOp tc) t2) acc
132 = checkTyVars (t1:t2:acc) `thenP` \ tvs ->
134 go (HsParTy ty) acc = go ty acc
135 go (HsAppTy t1 t2) acc = go t1 (t2:acc)
136 go other acc = parseError "Malformed LHS to type of class declaration"
138 checkContext :: RdrNameHsType -> P RdrNameContext
139 checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
142 checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way
145 checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
146 | t == getRdrName unitTyCon = returnP []
149 = checkPred t `thenP` \p ->
152 checkPred :: RdrNameHsType -> P (HsPred RdrName)
153 -- Watch out.. in ...deriving( Show )... we use checkPred on
154 -- the list of partially applied predicates in the deriving,
155 -- so there can be zero args.
156 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
160 go (HsTyVar t) args | not (isRdrTyVar t)
161 = returnP (HsClassP t args)
162 go (HsAppTy l r) args = go l (r:args)
163 go (HsParTy t) args = go t args
164 go _ _ = parseError "Illegal class assertion"
166 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
167 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
168 = returnP (mkHsDictTy t args)
169 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
170 checkDictTy (HsParTy t) args = checkDictTy t args
171 checkDictTy _ _ = parseError "Malformed context in instance header"
174 ---------------------------------------------------------------------------
175 -- Checking statements in a do-expression
176 -- We parse do { e1 ; e2 ; }
177 -- as [ExprStmt e1, ExprStmt e2]
178 -- checkDo (a) checks that the last thing is an ExprStmt
179 -- (b) transforms it to a ResultStmt
181 checkDo [] = parseError "Empty 'do' construct"
182 checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
183 checkDo [s] = parseError "The last statement in a 'do' construct must be an expression"
184 checkDo (s:ss) = checkDo ss `thenP` \ ss' ->
187 ---------------------------------------------------------------------------
188 -- Checking Patterns.
190 -- We parse patterns as expressions and check for valid patterns below,
191 -- converting the expression into a pattern at the same time.
193 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
194 checkPattern loc e = setSrcLocP loc (checkPat e [])
196 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
197 checkPatterns loc es = mapP (checkPattern loc) es
199 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
200 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
201 checkPat (HsApp f x) args =
202 checkPat x [] `thenP` \x ->
204 checkPat e [] = case e of
205 EWildPat -> returnP (WildPat placeHolderType)
206 HsVar x -> returnP (VarPat x)
207 HsLit l -> returnP (LitPat l)
208 HsOverLit l -> returnP (NPatIn l Nothing)
209 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat)
210 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n)
211 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
212 -- Pattern signatures are parsed as sigtypes,
213 -- but they aren't explicit forall points. Hence
214 -- we have to remove the implicit forall here.
216 HsForAllTy Nothing [] ty -> ty
219 returnP (SigPatIn e t')
221 -- Translate out NegApps of literals in patterns. We negate
222 -- the Integer here, and add back the call to 'negate' when
223 -- we typecheck the pattern.
224 -- NB. Negative *primitive* literals are already handled by
225 -- RdrHsSyn.mkHsNegApp
226 NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
228 OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
230 -> returnP (mkNPlusKPat n lit)
232 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
234 OpApp l op fix r -> checkPat l [] `thenP` \l ->
235 checkPat r [] `thenP` \r ->
237 HsVar c | isDataOcc (rdrNameOcc c)
238 -> returnP (ConPatIn c (InfixCon l r))
241 HsPar e -> checkPat e [] `thenP` (returnP . ParPat)
242 ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
243 returnP (ListPat ps placeHolderType)
244 ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
245 returnP (PArrPat ps placeHolderType)
247 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
248 returnP (TuplePat ps b)
250 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
251 returnP (ConPatIn c (RecCon fs))
253 HsType ty -> returnP (TypePat ty)
256 checkPat _ _ = patFail
258 checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
259 checkPatField (n,e) = checkPat e [] `thenP` \p ->
262 patFail = parseError "Parse error in pattern"
265 ---------------------------------------------------------------------------
266 -- Check Equation Syntax
270 -> Maybe RdrNameHsType
275 checkValDef lhs opt_sig grhss loc
276 = case isFunLhs lhs [] of
278 checkPatterns loc es `thenP` \ps ->
279 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
282 checkPattern loc lhs `thenP` \lhs ->
283 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
290 checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrSig (Sig v ty loc))
291 checkValSig other ty loc = parseError "Type signature given for an expression"
294 -- A variable binding is parsed as an RdrNameFunMonoBind.
295 -- See comments with HsBinds.MonoBinds
297 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
298 isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
299 = Just (op, True, (l:r:es))
301 = case isFunLhs l es of
302 Just (op', True, j : k : es') ->
303 Just (op', True, j : OpApp k (HsVar op) fix r : es')
305 isFunLhs (HsVar f) es | not (isRdrDataCon f)
307 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
308 isFunLhs (HsPar e) es@(_:_) = isFunLhs e es
309 isFunLhs _ _ = Nothing
311 ---------------------------------------------------------------------------
312 -- Miscellaneous utilities
314 checkPrec :: Integer -> P ()
315 checkPrec i | 0 <= i && i <= 9 = returnP ()
316 | otherwise = parseError "Precedence out of range"
320 -> RdrNameHsRecordBinds
323 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
324 = returnP (RecordCon c fs)
325 mkRecConstrOrUpdate exp fs@(_:_)
326 = returnP (RecordUpd exp fs)
327 mkRecConstrOrUpdate _ _
328 = parseError "Empty record update"
330 -----------------------------------------------------------------------------
331 -- utilities for foreign declarations
333 -- supported calling conventions
335 data CallConv = CCall CCallConv -- ccall or stdcall
338 -- construct a foreign import declaration
342 -> (FastString, RdrName, RdrNameHsType)
345 mkImport (CCall cconv) safety (entity, v, ty) loc =
346 parseCImport entity cconv safety v `thenP` \importSpec ->
347 returnP $ ForD (ForeignImport v ty importSpec False loc)
348 mkImport (DNCall ) _ (entity, v, ty) loc =
349 returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
351 -- parse the entity string of a foreign import declaration for the `ccall' or
352 -- `stdcall' calling convention'
354 parseCImport :: FastString
359 parseCImport entity cconv safety v
360 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
361 | entity == FSLIT ("dynamic") =
362 returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
363 | entity == FSLIT ("wrapper") =
364 returnP $ CImport cconv safety nilFS nilFS CWrapper
365 | otherwise = parse0 (unpackFS entity)
367 -- using the static keyword?
368 parse0 (' ': rest) = parse0 rest
369 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
370 parse0 rest = parse1 rest
371 -- check for header file name
372 parse1 "" = parse4 "" nilFS False nilFS
373 parse1 (' ':rest) = parse1 rest
374 parse1 str@('&':_ ) = parse2 str nilFS
375 parse1 str@('[':_ ) = parse3 str nilFS False
377 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
378 | otherwise = parse4 str nilFS False nilFS
380 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
381 -- check for address operator (indicating a label import)
382 parse2 "" header = parse4 "" header False nilFS
383 parse2 (' ':rest) header = parse2 rest header
384 parse2 ('&':rest) header = parse3 rest header True
385 parse2 str@('[':_ ) header = parse3 str header False
386 parse2 str header = parse4 str header False nilFS
387 -- check for library object name
388 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
389 parse3 ('[':rest) header isLbl =
390 case break (== ']') rest of
391 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
392 _ -> parseError "Missing ']' in entity"
393 parse3 str header isLbl = parse4 str header isLbl nilFS
394 -- check for name of C function
395 parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib
396 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
397 parse4 str header isLbl lib
398 | all (== ' ') rest = build (mkFastString first) header isLbl lib
399 | otherwise = parseError "Malformed entity string"
401 (first, rest) = break (== ' ') str
403 build cid header False lib = returnP $
404 CImport cconv safety header lib (CFunction (StaticTarget cid))
405 build cid header True lib = returnP $
406 CImport cconv safety header lib (CLabel cid )
408 -- construct a foreign export declaration
411 -> (FastString, RdrName, RdrNameHsType)
414 mkExport (CCall cconv) (entity, v, ty) loc = returnP $
415 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
417 entity' | nullFastString entity = mkExtName v
419 mkExport DNCall (entity, v, ty) loc =
420 parseError "Foreign export is not yet supported for .NET"
422 -- Supplying the ext_name in a foreign decl is optional; if it
423 -- isn't there, the Haskell name is assumed. Note that no transformation
424 -- of the Haskell name is then performed, so if you foreign export (++),
425 -- it's external name will be "++". Too bad; it's important because we don't
426 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
427 -- (This is why we use occNameUserString.)
429 mkExtName :: RdrName -> CLabelString
430 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
432 -----------------------------------------------------------------------------
433 -- group function bindings into equation groups
435 -- we assume the bindings are coming in reverse order, so we take the srcloc
436 -- from the *last* binding in the group as the srcloc for the whole group.
438 groupBindings :: [RdrBinding] -> RdrBinding
439 groupBindings binds = group Nothing binds
440 where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding
441 group (Just bind) [] = RdrValBinding bind
442 group Nothing [] = RdrNullBind
444 -- don't group together FunMonoBinds if they have
445 -- no arguments. This is necessary now that variable bindings
446 -- with no arguments are now treated as FunMonoBinds rather
447 -- than pattern bindings (tests/rename/should_fail/rnfail002).
448 group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
449 (RdrValBinding (FunMonoBind f' _
450 [mtch@(Match (_:_) _ _)] loc)
452 | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
454 group (Just so_far) binds
455 = RdrValBinding so_far `RdrAndBindings` group Nothing binds
456 group Nothing (bind:binds)
458 RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
459 other -> bind `RdrAndBindings` group Nothing binds
461 -- ---------------------------------------------------------------------------
462 -- Make the export list for an interface
464 mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
465 mkIfaceExports decls = map getExport decls
466 where getExport d = case d of
467 TyData{} -> tc_export
468 ClassDecl{} -> tc_export
471 tc_export = AvailTC (rdrNameOcc (tcdName d))
472 (map (rdrNameOcc.fst) (tyClDeclNames d))
473 var_export = Avail (rdrNameOcc (tcdName d))