2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
6 (Well, really, for specialisations involving @RdrName@s, even if
7 they are used somewhat later on in the compiler...)
46 extractHsTyRdrNames, extractHsTyRdrTyVars,
47 extractHsCtxtRdrTyVars, extractGenericPatTyVars,
49 mkHsOpApp, mkClassDecl, mkClassOpSigDM,
50 mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
51 mkHsDo, mkHsSplice, mkSigDecls,
52 mkTyData, mkPrefixCon, mkRecCon,
53 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
54 mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem]
60 findSplice, addImpDecls, emptyGroup, mkGroup,
62 -- Stuff to do with Foreign declarations
64 , mkImport -- CallConv -> Safety
65 -- -> (FastString, RdrName, RdrNameHsType)
68 , mkExport -- CallConv
69 -- -> (FastString, RdrName, RdrNameHsType)
72 , mkExtName -- RdrName -> CLabelString
74 -- Bunch of functions in the parser monad for
75 -- checking and constructing values
76 , checkPrecP -- Int -> P Int
77 , checkContext -- HsType -> P HsContext
78 , checkPred -- HsType -> P HsPred
79 , checkTyVars -- [HsTyVar] -> P [HsType]
80 , checkTyClHdr -- HsType -> (name,[tyvar])
81 , checkInstType -- HsType -> P HsType
82 , checkPattern -- HsExp -> P HsPat
83 , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
84 , checkDo -- [Stmt] -> P [Stmt]
85 , checkMDo -- [Stmt] -> P [Stmt]
86 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
87 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
88 , parseError -- String -> Pa
91 #include "HsVersions.h"
93 import HsSyn -- Lots of it
94 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc,
95 isRdrTyVar, isRdrDataCon, isUnqual, getRdrName,
97 import BasicTypes ( RecFlag(..), FixitySig(..), maxPrecedence )
98 import Class ( DefMeth (..) )
99 import Lex ( P, mapP, setSrcLocP, thenP, returnP, getSrcLocP, failMsgP )
100 import HscTypes ( RdrAvailInfo, GenAvailInfo(..) )
101 import TysWiredIn ( unitTyCon )
102 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
104 import OccName ( dataName, varName, isDataOcc, isTcOcc, occNameUserString,
105 mkDefaultMethodOcc, mkVarOcc )
107 import CStrings ( CLabelString )
108 import List ( isSuffixOf, nub )
115 %************************************************************************
117 \subsection{Type synonyms}
119 %************************************************************************
122 type RdrNameArithSeqInfo = ArithSeqInfo RdrName
123 type RdrNameBangType = BangType RdrName
124 type RdrNameClassOpSig = Sig RdrName
125 type RdrNameConDecl = ConDecl RdrName
126 type RdrNameConDetails = HsConDetails RdrName RdrNameBangType
127 type RdrNameContext = HsContext RdrName
128 type RdrNameHsDecl = HsDecl RdrName
129 type RdrNameDefaultDecl = DefaultDecl RdrName
130 type RdrNameForeignDecl = ForeignDecl RdrName
131 type RdrNameCoreDecl = CoreDecl RdrName
132 type RdrNameGRHS = GRHS RdrName
133 type RdrNameGRHSs = GRHSs RdrName
134 type RdrNameHsBinds = HsBinds RdrName
135 type RdrNameHsExpr = HsExpr RdrName
136 type RdrNameHsModule = HsModule RdrName
137 type RdrNameIE = IE RdrName
138 type RdrNameImportDecl = ImportDecl RdrName
139 type RdrNameInstDecl = InstDecl RdrName
140 type RdrNameMatch = Match RdrName
141 type RdrNameMonoBinds = MonoBinds RdrName
142 type RdrNamePat = InPat RdrName
143 type RdrNameHsType = HsType RdrName
144 type RdrNameHsTyVar = HsTyVarBndr RdrName
145 type RdrNameSig = Sig RdrName
146 type RdrNameStmt = Stmt RdrName
147 type RdrNameTyClDecl = TyClDecl RdrName
149 type RdrNameRuleBndr = RuleBndr RdrName
150 type RdrNameRuleDecl = RuleDecl RdrName
151 type RdrNameDeprecation = DeprecDecl RdrName
152 type RdrNameFixitySig = FixitySig RdrName
154 type RdrNameHsRecordBinds = HsRecordBinds RdrName
158 %************************************************************************
160 \subsection{A few functions over HsSyn at RdrName}
162 %************************************************************************
164 @extractHsTyRdrNames@ finds the free variables of a HsType
165 It's used when making the for-alls explicit.
168 extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
169 extractHsTyRdrNames ty = nub (extract_ty ty [])
171 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
172 extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
174 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
175 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
176 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
177 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
179 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
181 extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
182 extract_pred (HsIParam n ty) acc = extract_ty ty acc
184 extract_tys tys = foldr extract_ty [] tys
186 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
187 extract_ty (HsListTy ty) acc = extract_ty ty acc
188 extract_ty (HsPArrTy ty) acc = extract_ty ty acc
189 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
190 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
191 extract_ty (HsPredTy p) acc = extract_pred p acc
192 extract_ty (HsTyVar tv) acc = tv : acc
193 extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
194 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
195 extract_ty (HsParTy ty) acc = extract_ty ty acc
197 extract_ty (HsNumTy num) acc = acc
198 extract_ty (HsKindSig ty k) acc = extract_ty ty acc
199 extract_ty (HsForAllTy (Just tvs) ctxt ty)
201 (filter (`notElem` locals) $
202 extract_ctxt ctxt (extract_ty ty []))
204 locals = hsTyVarNames tvs
206 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
207 -- Get the type variables out of the type patterns in a bunch of
208 -- possibly-generic bindings in a class declaration
209 extractGenericPatTyVars binds
210 = filter isRdrTyVar (nub (get binds []))
212 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
213 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
216 get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc
217 get_m other acc = acc
221 %************************************************************************
223 \subsection{Construction functions for Rdr stuff}
225 %************************************************************************
227 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
228 by deriving them from the name of the class. We fill in the names for the
229 tycon and datacon corresponding to the class, by deriving them from the
230 name of the class itself. This saves recording the names in the interface
231 file (which would be equally good).
233 Similarly for mkConDecl, mkClassOpSig and default-method names.
235 *** See "THE NAMING STORY" in HsDecls ****
238 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
239 = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
240 tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
243 mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
244 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
245 tcdTyVars = tyvars, tcdCons = data_cons,
246 tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing }
248 mkClassOpSigDM op ty loc
249 = ClassOpSig op (DefMeth dm_rn) ty loc
251 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
255 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
256 -- If the type checker sees (negate 3#) it will barf, because negate
257 -- can't take an unboxed arg. But that is exactly what it will see when
258 -- we write "-3#". So we have to do the negation right now!
260 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
261 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
262 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
263 mkHsNegApp expr = NegApp expr placeHolderName
266 A useful function for building @OpApps@. The operator is always a
267 variable, and we don't know the fixity yet.
270 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
273 These are the bits of syntax that contain rebindable names
274 See RnEnv.lookupSyntaxName
277 mkHsIntegral i = HsIntegral i placeHolderName
278 mkHsFractional f = HsFractional f placeHolderName
279 mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
280 mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
284 mkHsSplice e loc = HsSplice unqualSplice e loc
286 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
287 -- A name (uniquified later) to
288 -- identify the splice
291 %************************************************************************
293 \subsection[rdrBinding]{Bindings straight out of the parser}
295 %************************************************************************
299 = -- Value bindings havn't been united with their
301 RdrBindings [RdrBinding] -- Convenience for parsing
303 | RdrValBinding RdrNameMonoBinds
305 -- The remainder all fit into the main HsDecl form
306 | RdrHsDecl RdrNameHsDecl
313 (Maybe RdrNameHsType)
317 %************************************************************************
319 \subsection[cvDecls]{Convert various top-level declarations}
321 %************************************************************************
323 We make a point not to throw any user-pragma ``sigs'' at
324 these conversion functions:
327 cvClassOpSig :: RdrNameSig -> RdrNameSig
328 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
329 cvClassOpSig sig = sig
333 %************************************************************************
335 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
337 %************************************************************************
339 Function definitions are restructured here. Each is assumed to be recursive
340 initially, and non recursive definitions are discovered by the dependency
345 cvTopDecls :: [RdrBinding] -> [RdrNameHsDecl]
346 -- Incoming bindings are in reverse order; result is in ordinary order
347 -- (a) flatten RdrBindings
348 -- (b) Group together bindings for a single function
352 go :: [RdrNameHsDecl] -> [RdrBinding] -> [RdrNameHsDecl]
354 go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2
355 go acc (RdrHsDecl d : ds) = go (d : acc) ds
356 go acc (RdrValBinding b : ds) = go (ValD b' : acc) ds'
358 (b', ds') = getMonoBind b ds
360 cvBinds :: [RdrBinding] -> RdrNameHsBinds
362 = case (cvMonoBindsAndSigs binding) of { (mbs, sigs) ->
363 MonoBind mbs sigs Recursive
366 cvMonoBindsAndSigs :: [RdrBinding] -> (RdrNameMonoBinds, [RdrNameSig])
367 -- Input bindings are in *reverse* order,
368 -- and contain just value bindings and signatuers
370 cvMonoBindsAndSigs fb
371 = go (EmptyMonoBinds, []) fb
374 go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2
375 go (bs, ss) (RdrHsDecl (SigD s) : ds) = go (bs, s : ss) ds
376 go (bs, ss) (RdrValBinding b : ds) = go (b' `AndMonoBinds` bs, ss) ds'
378 (b',ds') = getMonoBind b ds
380 -----------------------------------------------------------------------------
381 -- Group function bindings into equation groups
383 getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBinding])
384 -- Suppose (b',ds') = getMonoBind b ds
385 -- ds is a *reversed* list of parsed bindings
386 -- b is a MonoBinds that has just been read off the front
388 -- Then b' is the result of grouping more equations from ds that
389 -- belong with b into a single MonoBinds, and ds' is the depleted
390 -- list of parsed bindings.
392 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
394 getMonoBind (FunMonoBind f inf mtchs loc) binds
398 go mtchs1 loc1 (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds)
399 | f == f2 = go (mtchs2 ++ mtchs1) loc2 binds
400 -- Remember binds is reversed, so glue mtchs2 on the front
401 -- and use loc2 as the final location
402 go mtchs1 loc1 binds = (FunMonoBind f inf mtchs1 loc1, binds)
404 getMonoBind bind binds = (bind, binds)
406 has_args ((Match args _ _) : _) = not (null args)
407 -- Don't group together FunMonoBinds if they have
408 -- no arguments. This is necessary now that variable bindings
409 -- with no arguments are now treated as FunMonoBinds rather
410 -- than pattern bindings (tests/rename/should_fail/rnfail002).
414 emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive,
415 -- The renamer adds structure to the bindings;
416 -- they start life as a single giant MonoBinds
417 hs_tyclds = [], hs_instds = [],
418 hs_fixds = [], hs_defds = [], hs_fords = [],
419 hs_depds = [] ,hs_ruleds = [], hs_coreds = [] }
421 findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
422 findSplice ds = add emptyGroup ds
424 mkGroup :: [HsDecl a] -> HsGroup a
425 mkGroup ds = addImpDecls emptyGroup ds
427 addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a
428 -- The decls are imported, and should not have a splice
429 addImpDecls group decls = case add group decls of
430 (group', Nothing) -> group'
431 other -> panic "addImpDecls"
433 add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
434 -- This stuff reverses the declarations (again) but it doesn't matter
437 add gp [] = (gp, Nothing)
438 add gp (SpliceD e : ds) = (gp, Just (e, ds))
440 -- Class declarations: pull out the fixity signatures to the top
441 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds)
442 | isClassDecl d = add (gp { hs_tyclds = d : ts,
443 hs_fixds = [f | FixSig f <- tcdSigs d] ++ fs }) ds
444 | otherwise = add (gp { hs_tyclds = d : ts }) ds
446 -- Signatures: fixity sigs go a different place than all others
447 add gp@(HsGroup {hs_fixds = ts}) (SigD (FixSig f) : ds) = add (gp {hs_fixds = f : ts}) ds
448 add gp@(HsGroup {hs_valds = ts}) (SigD d : ds) = add (gp {hs_valds = add_sig d ts}) ds
450 -- Value declarations: use add_bind
451 add gp@(HsGroup {hs_valds = ts}) (ValD d : ds) = add (gp { hs_valds = add_bind d ts }) ds
453 -- The rest are routine
454 add gp@(HsGroup {hs_instds = ts}) (InstD d : ds) = add (gp { hs_instds = d : ts }) ds
455 add gp@(HsGroup {hs_defds = ts}) (DefD d : ds) = add (gp { hs_defds = d : ts }) ds
456 add gp@(HsGroup {hs_fords = ts}) (ForD d : ds) = add (gp { hs_fords = d : ts }) ds
457 add gp@(HsGroup {hs_depds = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds
458 add gp@(HsGroup {hs_ruleds = ts})(RuleD d : ds) = add (gp { hs_ruleds = d : ts }) ds
459 add gp@(HsGroup {hs_coreds = ts})(CoreD d : ds) = add (gp { hs_coreds = d : ts }) ds
461 add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r
462 add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r
465 %************************************************************************
467 \subsection[PrefixToHS-utils]{Utilities for conversion}
469 %************************************************************************
473 -----------------------------------------------------------------------------
476 -- When parsing data declarations, we sometimes inadvertently parse
477 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
478 -- This function splits up the type application, adds any pending
479 -- arguments, and converts the type constructor back into a data constructor.
481 mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
486 split (HsAppTy t u) ts = split t (unbangedType u : ts)
487 split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
488 returnP (data_con, PrefixCon ts)
489 split _ _ = parseError "Illegal data/newtype declaration"
491 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
493 = tyConToDataCon con `thenP` \ data_con ->
494 returnP (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
496 tyConToDataCon :: RdrName -> P RdrName
498 | isTcOcc (rdrNameOcc tc)
499 = returnP (setRdrNameSpace tc dataName)
501 = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
503 ----------------------------------------------------------------------------
504 -- Various Syntactic Checks
506 checkInstType :: RdrNameHsType -> P RdrNameHsType
509 HsForAllTy tvs ctxt ty ->
510 checkDictTy ty [] `thenP` \ dict_ty ->
511 returnP (HsForAllTy tvs ctxt dict_ty)
513 HsParTy ty -> checkInstType ty
515 ty -> checkDictTy ty [] `thenP` \ dict_ty->
516 returnP (HsForAllTy Nothing [] dict_ty)
518 checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
519 checkTyVars tvs = mapP chk tvs
521 chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k)
522 chk (HsTyVar tv) = returnP (UserTyVar tv)
523 chk other = parseError "Type found where type variable expected"
525 checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
526 -- The header of a type or class decl should look like
527 -- (C a, D b) => T a b
535 | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs ->
537 go (HsOpTy t1 (HsTyOp tc) t2) acc
538 = checkTyVars (t1:t2:acc) `thenP` \ tvs ->
540 go (HsParTy ty) acc = go ty acc
541 go (HsAppTy t1 t2) acc = go t1 (t2:acc)
542 go other acc = parseError "Malformed LHS to type of class declaration"
544 checkContext :: RdrNameHsType -> P RdrNameContext
545 checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
548 checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way
551 checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
552 | t == getRdrName unitTyCon = returnP []
555 = checkPred t `thenP` \p ->
558 checkPred :: RdrNameHsType -> P (HsPred RdrName)
559 -- Watch out.. in ...deriving( Show )... we use checkPred on
560 -- the list of partially applied predicates in the deriving,
561 -- so there can be zero args.
562 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
566 go (HsTyVar t) args | not (isRdrTyVar t)
567 = returnP (HsClassP t args)
568 go (HsAppTy l r) args = go l (r:args)
569 go (HsParTy t) args = go t args
570 go _ _ = parseError "Illegal class assertion"
572 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
573 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
574 = returnP (mkHsDictTy t args)
575 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
576 checkDictTy (HsParTy t) args = checkDictTy t args
577 checkDictTy _ _ = parseError "Malformed context in instance header"
580 ---------------------------------------------------------------------------
581 -- Checking statements in a do-expression
582 -- We parse do { e1 ; e2 ; }
583 -- as [ExprStmt e1, ExprStmt e2]
584 -- checkDo (a) checks that the last thing is an ExprStmt
585 -- (b) transforms it to a ResultStmt
586 -- same comments apply for mdo as well
588 checkDo = checkDoMDo "a " "'do'"
589 checkMDo = checkDoMDo "an " "'mdo'"
591 checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct"
592 checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l]
593 checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
594 checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss `thenP` \ ss' ->
597 ---------------------------------------------------------------------------
598 -- Checking Patterns.
600 -- We parse patterns as expressions and check for valid patterns below,
601 -- converting the expression into a pattern at the same time.
603 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
604 checkPattern loc e = setSrcLocP loc (checkPat e [])
606 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
607 checkPatterns loc es = mapP (checkPattern loc) es
609 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
610 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
611 checkPat (HsApp f x) args =
612 checkPat x [] `thenP` \x ->
614 checkPat e [] = case e of
615 EWildPat -> returnP (WildPat placeHolderType)
616 HsVar x -> returnP (VarPat x)
617 HsLit l -> returnP (LitPat l)
618 HsOverLit l -> returnP (NPatIn l Nothing)
619 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat)
620 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n)
621 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
622 -- Pattern signatures are parsed as sigtypes,
623 -- but they aren't explicit forall points. Hence
624 -- we have to remove the implicit forall here.
626 HsForAllTy Nothing [] ty -> ty
629 returnP (SigPatIn e t')
631 -- Translate out NegApps of literals in patterns. We negate
632 -- the Integer here, and add back the call to 'negate' when
633 -- we typecheck the pattern.
634 -- NB. Negative *primitive* literals are already handled by
635 -- RdrHsSyn.mkHsNegApp
636 NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
638 OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
640 -> returnP (mkNPlusKPat n lit)
642 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
644 OpApp l op fix r -> checkPat l [] `thenP` \l ->
645 checkPat r [] `thenP` \r ->
647 HsVar c | isDataOcc (rdrNameOcc c)
648 -> returnP (ConPatIn c (InfixCon l r))
651 HsPar e -> checkPat e [] `thenP` (returnP . ParPat)
652 ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
653 returnP (ListPat ps placeHolderType)
654 ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
655 returnP (PArrPat ps placeHolderType)
657 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
658 returnP (TuplePat ps b)
660 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
661 returnP (ConPatIn c (RecCon fs))
663 HsType ty -> returnP (TypePat ty)
666 checkPat _ _ = patFail
668 checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
669 checkPatField (n,e) = checkPat e [] `thenP` \p ->
672 patFail = parseError "Parse error in pattern"
675 ---------------------------------------------------------------------------
676 -- Check Equation Syntax
680 -> Maybe RdrNameHsType
685 checkValDef lhs opt_sig grhss loc
686 = case isFunLhs lhs [] of
688 checkPatterns loc es `thenP` \ps ->
689 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
692 checkPattern loc lhs `thenP` \lhs ->
693 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
700 checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc)))
701 checkValSig other ty loc = parseError "Type signature given for an expression"
703 mkSigDecls :: [Sig RdrName] -> RdrBinding
704 mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs]
707 -- A variable binding is parsed as an RdrNameFunMonoBind.
708 -- See comments with HsBinds.MonoBinds
710 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
711 isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
712 = Just (op, True, (l:r:es))
714 = case isFunLhs l es of
715 Just (op', True, j : k : es') ->
716 Just (op', True, j : OpApp k (HsVar op) fix r : es')
718 isFunLhs (HsVar f) es | not (isRdrDataCon f)
720 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
721 isFunLhs (HsPar e) es@(_:_) = isFunLhs e es
722 isFunLhs _ _ = Nothing
724 ---------------------------------------------------------------------------
725 -- Miscellaneous utilities
727 checkPrecP :: Int -> P Int
728 checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i
729 | otherwise = parseError "Precedence out of range"
733 -> RdrNameHsRecordBinds
736 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
737 = returnP (RecordCon c fs)
738 mkRecConstrOrUpdate exp fs@(_:_)
739 = returnP (RecordUpd exp fs)
740 mkRecConstrOrUpdate _ _
741 = parseError "Empty record update"
743 -----------------------------------------------------------------------------
744 -- utilities for foreign declarations
746 -- supported calling conventions
748 data CallConv = CCall CCallConv -- ccall or stdcall
751 -- construct a foreign import declaration
755 -> (FastString, RdrName, RdrNameHsType)
758 mkImport (CCall cconv) safety (entity, v, ty) loc =
759 parseCImport entity cconv safety v `thenP` \importSpec ->
760 returnP $ ForD (ForeignImport v ty importSpec False loc)
761 mkImport (DNCall ) _ (entity, v, ty) loc =
762 returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
764 -- parse the entity string of a foreign import declaration for the `ccall' or
765 -- `stdcall' calling convention'
767 parseCImport :: FastString
772 parseCImport entity cconv safety v
773 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
774 | entity == FSLIT ("dynamic") =
775 returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
776 | entity == FSLIT ("wrapper") =
777 returnP $ CImport cconv safety nilFS nilFS CWrapper
778 | otherwise = parse0 (unpackFS entity)
780 -- using the static keyword?
781 parse0 (' ': rest) = parse0 rest
782 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
783 parse0 rest = parse1 rest
784 -- check for header file name
785 parse1 "" = parse4 "" nilFS False nilFS
786 parse1 (' ':rest) = parse1 rest
787 parse1 str@('&':_ ) = parse2 str nilFS
788 parse1 str@('[':_ ) = parse3 str nilFS False
790 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
791 | otherwise = parse4 str nilFS False nilFS
793 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
794 -- check for address operator (indicating a label import)
795 parse2 "" header = parse4 "" header False nilFS
796 parse2 (' ':rest) header = parse2 rest header
797 parse2 ('&':rest) header = parse3 rest header True
798 parse2 str@('[':_ ) header = parse3 str header False
799 parse2 str header = parse4 str header False nilFS
800 -- check for library object name
801 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
802 parse3 ('[':rest) header isLbl =
803 case break (== ']') rest of
804 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
805 _ -> parseError "Missing ']' in entity"
806 parse3 str header isLbl = parse4 str header isLbl nilFS
807 -- check for name of C function
808 parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib
809 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
810 parse4 str header isLbl lib
811 | all (== ' ') rest = build (mkFastString first) header isLbl lib
812 | otherwise = parseError "Malformed entity string"
814 (first, rest) = break (== ' ') str
816 build cid header False lib = returnP $
817 CImport cconv safety header lib (CFunction (StaticTarget cid))
818 build cid header True lib = returnP $
819 CImport cconv safety header lib (CLabel cid )
821 -- construct a foreign export declaration
824 -> (FastString, RdrName, RdrNameHsType)
827 mkExport (CCall cconv) (entity, v, ty) loc = returnP $
828 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
830 entity' | nullFastString entity = mkExtName v
832 mkExport DNCall (entity, v, ty) loc =
833 parseError "Foreign export is not yet supported for .NET"
835 -- Supplying the ext_name in a foreign decl is optional; if it
836 -- isn't there, the Haskell name is assumed. Note that no transformation
837 -- of the Haskell name is then performed, so if you foreign export (++),
838 -- it's external name will be "++". Too bad; it's important because we don't
839 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
840 -- (This is why we use occNameUserString.)
842 mkExtName :: RdrName -> CLabelString
843 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
845 -- ---------------------------------------------------------------------------
846 -- Make the export list for an interface
848 mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
849 mkIfaceExports decls = map getExport decls
850 where getExport d = case d of
851 TyData{} -> tc_export
852 ClassDecl{} -> tc_export
855 tc_export = AvailTC (rdrNameOcc (tcdName d))
856 (map (rdrNameOcc.fst) (tyClDeclNames d))
857 var_export = Avail (rdrNameOcc (tcdName d))
861 -----------------------------------------------------------------------------
865 parseError :: String -> P a
867 getSrcLocP `thenP` \ loc ->
868 failMsgP (hcat [ppr loc, text ": ", text s])