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...)
50 extractHsTyRdrNames, extractHsTyRdrTyVars,
51 extractHsCtxtRdrTyVars, extractGenericPatTyVars,
53 mkHsOpApp, mkClassDecl,
54 mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
55 mkHsDo, mkHsSplice, mkSigDecls,
56 mkTyData, mkPrefixCon, mkRecCon,
57 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
58 mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem]
63 findSplice, addImpDecls, emptyGroup, mkGroup,
65 -- Stuff to do with Foreign declarations
67 , mkImport -- CallConv -> Safety
68 -- -> (FastString, RdrName, RdrNameHsType)
71 , mkExport -- CallConv
72 -- -> (FastString, RdrName, RdrNameHsType)
75 , mkExtName -- RdrName -> CLabelString
77 -- Bunch of functions in the parser monad for
78 -- checking and constructing values
79 , checkPrecP -- Int -> P Int
80 , checkContext -- HsType -> P HsContext
81 , checkPred -- HsType -> P HsPred
82 , checkTyVars -- [HsTyVar] -> P [HsType]
83 , checkTyClHdr -- HsType -> (name,[tyvar])
84 , checkInstType -- HsType -> P HsType
85 , checkPattern -- HsExp -> P HsPat
86 , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
87 , checkDo -- [Stmt] -> P [Stmt]
88 , checkMDo -- [Stmt] -> P [Stmt]
89 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
90 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
91 , parseError -- String -> Pa
94 #include "HsVersions.h"
96 import HsSyn -- Lots of it
97 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc,
98 isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
100 import BasicTypes ( RecFlag(..), FixitySig(..), maxPrecedence )
101 import Class ( DefMeth (..) )
102 import Lex ( P, mapP, setSrcLocP, thenP, returnP, getSrcLocP, failMsgP )
103 import HscTypes ( RdrAvailInfo, GenAvailInfo(..) )
104 import TysWiredIn ( unitTyCon )
105 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
106 DNCallSpec(..), DNKind(..))
107 import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString,
108 mkDefaultMethodOcc, mkVarOcc )
110 import CStrings ( CLabelString )
111 import List ( isSuffixOf, nub )
118 %************************************************************************
120 \subsection{Type synonyms}
122 %************************************************************************
125 type RdrNameArithSeqInfo = ArithSeqInfo RdrName
126 type RdrNameBangType = BangType RdrName
127 type RdrNameClassOpSig = Sig RdrName
128 type RdrNameConDecl = ConDecl RdrName
129 type RdrNameConDetails = HsConDetails RdrName RdrNameBangType
130 type RdrNameContext = HsContext RdrName
131 type RdrNameHsDecl = HsDecl RdrName
132 type RdrNameDefaultDecl = DefaultDecl RdrName
133 type RdrNameForeignDecl = ForeignDecl RdrName
134 type RdrNameCoreDecl = CoreDecl RdrName
135 type RdrNameGRHS = GRHS RdrName
136 type RdrNameGRHSs = GRHSs RdrName
137 type RdrNameHsBinds = HsBinds RdrName
138 type RdrNameHsExpr = HsExpr RdrName
139 type RdrNameHsCmd = HsCmd RdrName
140 type RdrNameHsCmdTop = HsCmdTop RdrName
141 type RdrNameHsModule = HsModule RdrName
142 type RdrNameIE = IE RdrName
143 type RdrNameImportDecl = ImportDecl RdrName
144 type RdrNameInstDecl = InstDecl RdrName
145 type RdrNameMatch = Match RdrName
146 type RdrNameMonoBinds = MonoBinds RdrName
147 type RdrNamePat = InPat RdrName
148 type RdrNameHsType = HsType RdrName
149 type RdrNameHsTyVar = HsTyVarBndr RdrName
150 type RdrNameSig = Sig RdrName
151 type RdrNameStmt = Stmt RdrName
152 type RdrNameTyClDecl = TyClDecl RdrName
154 type RdrNameRuleBndr = RuleBndr RdrName
155 type RdrNameRuleDecl = RuleDecl RdrName
156 type RdrNameDeprecation = DeprecDecl RdrName
157 type RdrNameFixitySig = FixitySig RdrName
159 type RdrNameHsRecordBinds = HsRecordBinds RdrName
163 main_RDR_Unqual :: RdrName
164 main_RDR_Unqual = mkUnqual varName FSLIT("main")
165 -- We definitely don't want an Orig RdrName, because
166 -- main might, in principle, be imported into module Main
169 %************************************************************************
171 \subsection{A few functions over HsSyn at RdrName}
173 %************************************************************************
175 @extractHsTyRdrNames@ finds the free variables of a HsType
176 It's used when making the for-alls explicit.
179 extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
180 extractHsTyRdrNames ty = nub (extract_ty ty [])
182 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
183 extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
185 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
186 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
187 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
188 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
190 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
192 extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
193 extract_pred (HsIParam n ty) acc = extract_ty ty acc
195 extract_tys tys = foldr extract_ty [] tys
197 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
198 extract_ty (HsListTy ty) acc = extract_ty ty acc
199 extract_ty (HsPArrTy ty) acc = extract_ty ty acc
200 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
201 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
202 extract_ty (HsPredTy p) acc = extract_pred p acc
203 extract_ty (HsTyVar tv) acc = tv : acc
204 extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
205 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
206 extract_ty (HsParTy ty) acc = extract_ty ty acc
208 extract_ty (HsNumTy num) acc = acc
209 extract_ty (HsKindSig ty k) acc = extract_ty ty acc
210 extract_ty (HsForAllTy (Just tvs) ctxt ty)
212 (filter (`notElem` locals) $
213 extract_ctxt ctxt (extract_ty ty []))
215 locals = hsTyVarNames tvs
217 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
218 -- Get the type variables out of the type patterns in a bunch of
219 -- possibly-generic bindings in a class declaration
220 extractGenericPatTyVars binds
221 = filter isRdrTyVar (nub (get binds []))
223 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
224 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
227 get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc
228 get_m other acc = acc
232 %************************************************************************
234 \subsection{Construction functions for Rdr stuff}
236 %************************************************************************
238 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
239 by deriving them from the name of the class. We fill in the names for the
240 tycon and datacon corresponding to the class, by deriving them from the
241 name of the class itself. This saves recording the names in the interface
242 file (which would be equally good).
244 Similarly for mkConDecl, mkClassOpSig and default-method names.
246 *** See "THE NAMING STORY" in HsDecls ****
249 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
250 = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
252 tcdSigs = map cvClassOpSig sigs, -- Convert to class-op sigs
256 mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
257 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
258 tcdTyVars = tyvars, tcdCons = data_cons,
259 tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing }
261 cvClassOpSig :: RdrNameSig -> RdrNameSig
262 cvClassOpSig (Sig var poly_ty src_loc)
263 = ClassOpSig var (DefMeth dm_rn) poly_ty src_loc
265 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc var))
271 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
272 -- If the type checker sees (negate 3#) it will barf, because negate
273 -- can't take an unboxed arg. But that is exactly what it will see when
274 -- we write "-3#". So we have to do the negation right now!
276 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
277 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
278 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
279 mkHsNegApp expr = NegApp expr placeHolderName
282 A useful function for building @OpApps@. The operator is always a
283 variable, and we don't know the fixity yet.
286 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
289 These are the bits of syntax that contain rebindable names
290 See RnEnv.lookupSyntaxName
293 mkHsIntegral i = HsIntegral i placeHolderName
294 mkHsFractional f = HsFractional f placeHolderName
295 mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
296 mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
300 mkHsSplice e loc = HsSplice unqualSplice e loc
302 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
303 -- A name (uniquified later) to
304 -- identify the splice
307 %************************************************************************
309 \subsection[rdrBinding]{Bindings straight out of the parser}
311 %************************************************************************
315 = -- Value bindings havn't been united with their
317 RdrBindings [RdrBinding] -- Convenience for parsing
319 | RdrValBinding RdrNameMonoBinds
321 -- The remainder all fit into the main HsDecl form
322 | RdrHsDecl RdrNameHsDecl
329 (Maybe RdrNameHsType)
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 srcDataName)
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]
522 -- Check that the name space is correct!
523 chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = returnP (IfaceTyVar tv k)
524 chk (HsTyVar tv) | isRdrTyVar tv = returnP (UserTyVar tv)
525 chk other = parseError "Type found where type variable expected"
527 checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
528 -- The header of a type or class decl should look like
529 -- (C a, D b) => T a b
537 | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs ->
539 go (HsOpTy t1 (HsTyOp tc) t2) acc
540 = checkTyVars (t1:t2:acc) `thenP` \ tvs ->
542 go (HsParTy ty) acc = go ty acc
543 go (HsAppTy t1 t2) acc = go t1 (t2:acc)
544 go other acc = parseError "Malformed LHS to type of class declaration"
546 checkContext :: RdrNameHsType -> P RdrNameContext
547 checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
550 checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way
553 checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
554 | t == getRdrName unitTyCon = returnP []
557 = checkPred t `thenP` \p ->
560 checkPred :: RdrNameHsType -> P (HsPred RdrName)
561 -- Watch out.. in ...deriving( Show )... we use checkPred on
562 -- the list of partially applied predicates in the deriving,
563 -- so there can be zero args.
564 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
568 go (HsTyVar t) args | not (isRdrTyVar t)
569 = returnP (HsClassP t args)
570 go (HsAppTy l r) args = go l (r:args)
571 go (HsParTy t) args = go t args
572 go _ _ = parseError "Illegal class assertion"
574 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
575 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
576 = returnP (mkHsDictTy t args)
577 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
578 checkDictTy (HsParTy t) args = checkDictTy t args
579 checkDictTy _ _ = parseError "Malformed context in instance header"
582 ---------------------------------------------------------------------------
583 -- Checking statements in a do-expression
584 -- We parse do { e1 ; e2 ; }
585 -- as [ExprStmt e1, ExprStmt e2]
586 -- checkDo (a) checks that the last thing is an ExprStmt
587 -- (b) transforms it to a ResultStmt
588 -- same comments apply for mdo as well
590 checkDo = checkDoMDo "a " "'do'"
591 checkMDo = checkDoMDo "an " "'mdo'"
593 checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct"
594 checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l]
595 checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
596 checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss `thenP` \ ss' ->
599 ---------------------------------------------------------------------------
600 -- Checking Patterns.
602 -- We parse patterns as expressions and check for valid patterns below,
603 -- converting the expression into a pattern at the same time.
605 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
606 checkPattern loc e = setSrcLocP loc (checkPat e [])
608 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
609 checkPatterns loc es = mapP (checkPattern loc) es
611 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
612 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
613 checkPat (HsApp f x) args =
614 checkPat x [] `thenP` \x ->
616 checkPat e [] = case e of
617 EWildPat -> returnP (WildPat placeHolderType)
618 HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x)
619 | otherwise -> returnP (VarPat x)
620 HsLit l -> returnP (LitPat l)
621 HsOverLit l -> returnP (NPatIn l Nothing)
622 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat)
623 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n)
624 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
625 -- Pattern signatures are parsed as sigtypes,
626 -- but they aren't explicit forall points. Hence
627 -- we have to remove the implicit forall here.
629 HsForAllTy Nothing [] ty -> ty
632 returnP (SigPatIn e t')
634 -- Translate out NegApps of literals in patterns. We negate
635 -- the Integer here, and add back the call to 'negate' when
636 -- we typecheck the pattern.
637 -- NB. Negative *primitive* literals are already handled by
638 -- RdrHsSyn.mkHsNegApp
639 NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
641 OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
643 -> returnP (mkNPlusKPat n lit)
645 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
647 OpApp l op fix r -> checkPat l [] `thenP` \l ->
648 checkPat r [] `thenP` \r ->
650 HsVar c | isDataOcc (rdrNameOcc c)
651 -> returnP (ConPatIn c (InfixCon l r))
654 HsPar e -> checkPat e [] `thenP` (returnP . ParPat)
655 ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
656 returnP (ListPat ps placeHolderType)
657 ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
658 returnP (PArrPat ps placeHolderType)
660 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
661 returnP (TuplePat ps b)
663 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
664 returnP (ConPatIn c (RecCon fs))
666 HsType ty -> returnP (TypePat ty)
669 checkPat _ _ = patFail
671 checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
672 checkPatField (n,e) = checkPat e [] `thenP` \p ->
675 patFail = parseError "Parse error in pattern"
678 ---------------------------------------------------------------------------
679 -- Check Equation Syntax
683 -> Maybe RdrNameHsType
688 checkValDef lhs opt_sig grhss loc
689 = case isFunLhs lhs [] of
692 -> parseError ("Qualified name in function definition: " ++ showRdrName f)
694 -> checkPatterns loc es `thenP` \ps ->
695 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
698 checkPattern loc lhs `thenP` \lhs ->
699 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
706 checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc)))
707 checkValSig other ty loc = parseError "Type signature given for an expression"
709 mkSigDecls :: [Sig RdrName] -> RdrBinding
710 mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs]
713 -- A variable binding is parsed as an RdrNameFunMonoBind.
714 -- See comments with HsBinds.MonoBinds
716 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
717 isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
718 = Just (op, True, (l:r:es))
720 = case isFunLhs l es of
721 Just (op', True, j : k : es') ->
722 Just (op', True, j : OpApp k (HsVar op) fix r : es')
724 isFunLhs (HsVar f) es | not (isRdrDataCon f)
726 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
727 isFunLhs (HsPar e) es@(_:_) = isFunLhs e es
728 isFunLhs _ _ = Nothing
730 ---------------------------------------------------------------------------
731 -- Miscellaneous utilities
733 checkPrecP :: Int -> P Int
734 checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i
735 | otherwise = parseError "Precedence out of range"
739 -> RdrNameHsRecordBinds
742 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
743 = returnP (RecordCon c fs)
744 mkRecConstrOrUpdate exp fs@(_:_)
745 = returnP (RecordUpd exp fs)
746 mkRecConstrOrUpdate _ _
747 = parseError "Empty record update"
749 -----------------------------------------------------------------------------
750 -- utilities for foreign declarations
752 -- supported calling conventions
754 data CallConv = CCall CCallConv -- ccall or stdcall
757 -- construct a foreign import declaration
761 -> (FastString, RdrName, RdrNameHsType)
764 mkImport (CCall cconv) safety (entity, v, ty) loc =
765 parseCImport entity cconv safety v `thenP` \importSpec ->
766 returnP $ ForD (ForeignImport v ty importSpec False loc)
767 mkImport (DNCall ) _ (entity, v, ty) loc =
768 parseDImport entity `thenP` \ spec ->
769 returnP $ ForD (ForeignImport v ty (DNImport spec) False loc)
771 -- parse the entity string of a foreign import declaration for the `ccall' or
772 -- `stdcall' calling convention'
774 parseCImport :: FastString
779 parseCImport entity cconv safety v
780 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
781 | entity == FSLIT ("dynamic") =
782 returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
783 | entity == FSLIT ("wrapper") =
784 returnP $ CImport cconv safety nilFS nilFS CWrapper
785 | otherwise = parse0 (unpackFS entity)
787 -- using the static keyword?
788 parse0 (' ': rest) = parse0 rest
789 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
790 parse0 rest = parse1 rest
791 -- check for header file name
792 parse1 "" = parse4 "" nilFS False nilFS
793 parse1 (' ':rest) = parse1 rest
794 parse1 str@('&':_ ) = parse2 str nilFS
795 parse1 str@('[':_ ) = parse3 str nilFS False
797 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
798 | otherwise = parse4 str nilFS False nilFS
800 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
801 -- check for address operator (indicating a label import)
802 parse2 "" header = parse4 "" header False nilFS
803 parse2 (' ':rest) header = parse2 rest header
804 parse2 ('&':rest) header = parse3 rest header True
805 parse2 str@('[':_ ) header = parse3 str header False
806 parse2 str header = parse4 str header False nilFS
807 -- check for library object name
808 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
809 parse3 ('[':rest) header isLbl =
810 case break (== ']') rest of
811 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
812 _ -> parseError "Missing ']' in entity"
813 parse3 str header isLbl = parse4 str header isLbl nilFS
814 -- check for name of C function
815 parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib
816 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
817 parse4 str header isLbl lib
818 | all (== ' ') rest = build (mkFastString first) header isLbl lib
819 | otherwise = parseError "Malformed entity string"
821 (first, rest) = break (== ' ') str
823 build cid header False lib = returnP $
824 CImport cconv safety header lib (CFunction (StaticTarget cid))
825 build cid header True lib = returnP $
826 CImport cconv safety header lib (CLabel cid )
829 -- Unravel a dotnet spec string.
831 parseDImport :: FastString -> P DNCallSpec
832 parseDImport entity = parse0 comps
834 comps = words (unpackFS entity)
838 | x == "static" = parse1 True xs
839 | otherwise = parse1 False (x:xs)
842 parse1 isStatic (x:xs)
843 | x == "method" = parse2 isStatic DNMethod xs
844 | x == "field" = parse2 isStatic DNField xs
845 | x == "ctor" = parse2 isStatic DNConstructor xs
846 parse1 isStatic xs = parse2 isStatic DNMethod xs
849 parse2 isStatic kind (('[':x):xs) =
852 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
853 parse2 isStatic kind xs = parse3 isStatic kind "" xs
855 parse3 isStatic kind assem [x] =
856 returnP (DNCallSpec isStatic kind assem x
857 -- these will be filled in once known.
858 (error "FFI-dotnet-args")
859 (error "FFI-dotnet-result"))
860 parse3 _ _ _ _ = d'oh
862 d'oh = parseError "Malformed entity string"
864 -- construct a foreign export declaration
867 -> (FastString, RdrName, RdrNameHsType)
870 mkExport (CCall cconv) (entity, v, ty) loc = returnP $
871 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
873 entity' | nullFastString entity = mkExtName v
875 mkExport DNCall (entity, v, ty) loc =
876 parseError "Foreign export is not yet supported for .NET"
878 -- Supplying the ext_name in a foreign decl is optional; if it
879 -- isn't there, the Haskell name is assumed. Note that no transformation
880 -- of the Haskell name is then performed, so if you foreign export (++),
881 -- it's external name will be "++". Too bad; it's important because we don't
882 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
883 -- (This is why we use occNameUserString.)
885 mkExtName :: RdrName -> CLabelString
886 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
888 -- ---------------------------------------------------------------------------
889 -- Make the export list for an interface
891 mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
892 mkIfaceExports decls = map getExport decls
893 where getExport d = case d of
894 TyData{} -> tc_export
895 ClassDecl{} -> tc_export
898 tc_export = AvailTC (rdrNameOcc (tcdName d))
899 (map (rdrNameOcc.fst) (tyClDeclNames d))
900 var_export = Avail (rdrNameOcc (tcdName d))
904 -----------------------------------------------------------------------------
908 showRdrName :: RdrName -> String
909 showRdrName r = showSDoc (ppr r)
911 parseError :: String -> P a
913 getSrcLocP `thenP` \ loc ->
914 failMsgP (hcat [ppr loc, text ": ", text s])