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...)
48 extractHsTyRdrNames, extractHsTyRdrTyVars,
49 extractHsCtxtRdrTyVars, extractGenericPatTyVars,
51 mkHsOpApp, mkClassDecl,
52 mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
53 mkHsDo, mkHsSplice, mkSigDecls,
54 mkTyData, mkPrefixCon, mkRecCon,
55 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
56 mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem]
61 findSplice, addImpDecls, emptyGroup, mkGroup,
63 -- Stuff to do with Foreign declarations
65 , mkImport -- CallConv -> Safety
66 -- -> (FastString, RdrName, RdrNameHsType)
69 , mkExport -- CallConv
70 -- -> (FastString, RdrName, RdrNameHsType)
73 , mkExtName -- RdrName -> CLabelString
75 -- Bunch of functions in the parser monad for
76 -- checking and constructing values
77 , checkPrecP -- Int -> P Int
78 , checkContext -- HsType -> P HsContext
79 , checkPred -- HsType -> P HsPred
80 , checkTyVars -- [HsTyVar] -> P [HsType]
81 , checkTyClHdr -- HsType -> (name,[tyvar])
82 , checkInstType -- HsType -> P HsType
83 , checkPattern -- HsExp -> P HsPat
84 , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
85 , checkDo -- [Stmt] -> P [Stmt]
86 , checkMDo -- [Stmt] -> P [Stmt]
87 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
88 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
89 , parseError -- String -> Pa
92 #include "HsVersions.h"
94 import HsSyn -- Lots of it
95 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc,
96 isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
98 import BasicTypes ( RecFlag(..), FixitySig(..), maxPrecedence )
99 import Class ( DefMeth (..) )
100 import Lex ( P, mapP, setSrcLocP, thenP, returnP, getSrcLocP, failMsgP )
101 import HscTypes ( RdrAvailInfo, GenAvailInfo(..) )
102 import TysWiredIn ( unitTyCon )
103 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
104 DNCallSpec(..), DNKind(..))
105 import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString,
106 mkDefaultMethodOcc, mkVarOcc )
108 import CStrings ( CLabelString )
109 import List ( isSuffixOf, nub )
116 %************************************************************************
118 \subsection{Type synonyms}
120 %************************************************************************
123 type RdrNameArithSeqInfo = ArithSeqInfo RdrName
124 type RdrNameBangType = BangType RdrName
125 type RdrNameClassOpSig = Sig RdrName
126 type RdrNameConDecl = ConDecl RdrName
127 type RdrNameConDetails = HsConDetails RdrName RdrNameBangType
128 type RdrNameContext = HsContext RdrName
129 type RdrNameHsDecl = HsDecl RdrName
130 type RdrNameDefaultDecl = DefaultDecl RdrName
131 type RdrNameForeignDecl = ForeignDecl RdrName
132 type RdrNameCoreDecl = CoreDecl RdrName
133 type RdrNameGRHS = GRHS RdrName
134 type RdrNameGRHSs = GRHSs RdrName
135 type RdrNameHsBinds = HsBinds RdrName
136 type RdrNameHsExpr = HsExpr RdrName
137 type RdrNameHsModule = HsModule RdrName
138 type RdrNameIE = IE RdrName
139 type RdrNameImportDecl = ImportDecl RdrName
140 type RdrNameInstDecl = InstDecl RdrName
141 type RdrNameMatch = Match RdrName
142 type RdrNameMonoBinds = MonoBinds RdrName
143 type RdrNamePat = InPat RdrName
144 type RdrNameHsType = HsType RdrName
145 type RdrNameHsTyVar = HsTyVarBndr RdrName
146 type RdrNameSig = Sig RdrName
147 type RdrNameStmt = Stmt RdrName
148 type RdrNameTyClDecl = TyClDecl RdrName
150 type RdrNameRuleBndr = RuleBndr RdrName
151 type RdrNameRuleDecl = RuleDecl RdrName
152 type RdrNameDeprecation = DeprecDecl RdrName
153 type RdrNameFixitySig = FixitySig RdrName
155 type RdrNameHsRecordBinds = HsRecordBinds RdrName
159 main_RDR_Unqual :: RdrName
160 main_RDR_Unqual = mkUnqual varName FSLIT("main")
161 -- We definitely don't want an Orig RdrName, because
162 -- main might, in principle, be imported into module Main
165 %************************************************************************
167 \subsection{A few functions over HsSyn at RdrName}
169 %************************************************************************
171 @extractHsTyRdrNames@ finds the free variables of a HsType
172 It's used when making the for-alls explicit.
175 extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
176 extractHsTyRdrNames ty = nub (extract_ty ty [])
178 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
179 extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
181 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
182 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
183 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
184 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
186 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
188 extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
189 extract_pred (HsIParam n ty) acc = extract_ty ty acc
191 extract_tys tys = foldr extract_ty [] tys
193 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
194 extract_ty (HsListTy ty) acc = extract_ty ty acc
195 extract_ty (HsPArrTy ty) acc = extract_ty ty acc
196 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
197 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
198 extract_ty (HsPredTy p) acc = extract_pred p acc
199 extract_ty (HsTyVar tv) acc = tv : acc
200 extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
201 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
202 extract_ty (HsParTy ty) acc = extract_ty ty acc
204 extract_ty (HsNumTy num) acc = acc
205 extract_ty (HsKindSig ty k) acc = extract_ty ty acc
206 extract_ty (HsForAllTy (Just tvs) ctxt ty)
208 (filter (`notElem` locals) $
209 extract_ctxt ctxt (extract_ty ty []))
211 locals = hsTyVarNames tvs
213 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
214 -- Get the type variables out of the type patterns in a bunch of
215 -- possibly-generic bindings in a class declaration
216 extractGenericPatTyVars binds
217 = filter isRdrTyVar (nub (get binds []))
219 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
220 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
223 get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc
224 get_m other acc = acc
228 %************************************************************************
230 \subsection{Construction functions for Rdr stuff}
232 %************************************************************************
234 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
235 by deriving them from the name of the class. We fill in the names for the
236 tycon and datacon corresponding to the class, by deriving them from the
237 name of the class itself. This saves recording the names in the interface
238 file (which would be equally good).
240 Similarly for mkConDecl, mkClassOpSig and default-method names.
242 *** See "THE NAMING STORY" in HsDecls ****
245 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
246 = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
248 tcdSigs = map cvClassOpSig sigs, -- Convert to class-op sigs
252 mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
253 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
254 tcdTyVars = tyvars, tcdCons = data_cons,
255 tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing }
257 cvClassOpSig :: RdrNameSig -> RdrNameSig
258 cvClassOpSig (Sig var poly_ty src_loc)
259 = ClassOpSig var (DefMeth dm_rn) poly_ty src_loc
261 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc var))
267 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
268 -- If the type checker sees (negate 3#) it will barf, because negate
269 -- can't take an unboxed arg. But that is exactly what it will see when
270 -- we write "-3#". So we have to do the negation right now!
272 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
273 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
274 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
275 mkHsNegApp expr = NegApp expr placeHolderName
278 A useful function for building @OpApps@. The operator is always a
279 variable, and we don't know the fixity yet.
282 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
285 These are the bits of syntax that contain rebindable names
286 See RnEnv.lookupSyntaxName
289 mkHsIntegral i = HsIntegral i placeHolderName
290 mkHsFractional f = HsFractional f placeHolderName
291 mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
292 mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
296 mkHsSplice e loc = HsSplice unqualSplice e loc
298 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
299 -- A name (uniquified later) to
300 -- identify the splice
303 %************************************************************************
305 \subsection[rdrBinding]{Bindings straight out of the parser}
307 %************************************************************************
311 = -- Value bindings havn't been united with their
313 RdrBindings [RdrBinding] -- Convenience for parsing
315 | RdrValBinding RdrNameMonoBinds
317 -- The remainder all fit into the main HsDecl form
318 | RdrHsDecl RdrNameHsDecl
325 (Maybe RdrNameHsType)
329 %************************************************************************
331 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
333 %************************************************************************
335 Function definitions are restructured here. Each is assumed to be recursive
336 initially, and non recursive definitions are discovered by the dependency
341 cvTopDecls :: [RdrBinding] -> [RdrNameHsDecl]
342 -- Incoming bindings are in reverse order; result is in ordinary order
343 -- (a) flatten RdrBindings
344 -- (b) Group together bindings for a single function
348 go :: [RdrNameHsDecl] -> [RdrBinding] -> [RdrNameHsDecl]
350 go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2
351 go acc (RdrHsDecl d : ds) = go (d : acc) ds
352 go acc (RdrValBinding b : ds) = go (ValD b' : acc) ds'
354 (b', ds') = getMonoBind b ds
356 cvBinds :: [RdrBinding] -> RdrNameHsBinds
358 = case (cvMonoBindsAndSigs binding) of { (mbs, sigs) ->
359 MonoBind mbs sigs Recursive
362 cvMonoBindsAndSigs :: [RdrBinding] -> (RdrNameMonoBinds, [RdrNameSig])
363 -- Input bindings are in *reverse* order,
364 -- and contain just value bindings and signatuers
366 cvMonoBindsAndSigs fb
367 = go (EmptyMonoBinds, []) fb
370 go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2
371 go (bs, ss) (RdrHsDecl (SigD s) : ds) = go (bs, s : ss) ds
372 go (bs, ss) (RdrValBinding b : ds) = go (b' `AndMonoBinds` bs, ss) ds'
374 (b',ds') = getMonoBind b ds
376 -----------------------------------------------------------------------------
377 -- Group function bindings into equation groups
379 getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBinding])
380 -- Suppose (b',ds') = getMonoBind b ds
381 -- ds is a *reversed* list of parsed bindings
382 -- b is a MonoBinds that has just been read off the front
384 -- Then b' is the result of grouping more equations from ds that
385 -- belong with b into a single MonoBinds, and ds' is the depleted
386 -- list of parsed bindings.
388 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
390 getMonoBind (FunMonoBind f inf mtchs loc) binds
394 go mtchs1 loc1 (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds)
395 | f == f2 = go (mtchs2 ++ mtchs1) loc2 binds
396 -- Remember binds is reversed, so glue mtchs2 on the front
397 -- and use loc2 as the final location
398 go mtchs1 loc1 binds = (FunMonoBind f inf mtchs1 loc1, binds)
400 getMonoBind bind binds = (bind, binds)
402 has_args ((Match args _ _) : _) = not (null args)
403 -- Don't group together FunMonoBinds if they have
404 -- no arguments. This is necessary now that variable bindings
405 -- with no arguments are now treated as FunMonoBinds rather
406 -- than pattern bindings (tests/rename/should_fail/rnfail002).
410 emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive,
411 -- The renamer adds structure to the bindings;
412 -- they start life as a single giant MonoBinds
413 hs_tyclds = [], hs_instds = [],
414 hs_fixds = [], hs_defds = [], hs_fords = [],
415 hs_depds = [] ,hs_ruleds = [], hs_coreds = [] }
417 findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
418 findSplice ds = add emptyGroup ds
420 mkGroup :: [HsDecl a] -> HsGroup a
421 mkGroup ds = addImpDecls emptyGroup ds
423 addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a
424 -- The decls are imported, and should not have a splice
425 addImpDecls group decls = case add group decls of
426 (group', Nothing) -> group'
427 other -> panic "addImpDecls"
429 add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
430 -- This stuff reverses the declarations (again) but it doesn't matter
433 add gp [] = (gp, Nothing)
434 add gp (SpliceD e : ds) = (gp, Just (e, ds))
436 -- Class declarations: pull out the fixity signatures to the top
437 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds)
438 | isClassDecl d = add (gp { hs_tyclds = d : ts,
439 hs_fixds = [f | FixSig f <- tcdSigs d] ++ fs }) ds
440 | otherwise = add (gp { hs_tyclds = d : ts }) ds
442 -- Signatures: fixity sigs go a different place than all others
443 add gp@(HsGroup {hs_fixds = ts}) (SigD (FixSig f) : ds) = add (gp {hs_fixds = f : ts}) ds
444 add gp@(HsGroup {hs_valds = ts}) (SigD d : ds) = add (gp {hs_valds = add_sig d ts}) ds
446 -- Value declarations: use add_bind
447 add gp@(HsGroup {hs_valds = ts}) (ValD d : ds) = add (gp { hs_valds = add_bind d ts }) ds
449 -- The rest are routine
450 add gp@(HsGroup {hs_instds = ts}) (InstD d : ds) = add (gp { hs_instds = d : ts }) ds
451 add gp@(HsGroup {hs_defds = ts}) (DefD d : ds) = add (gp { hs_defds = d : ts }) ds
452 add gp@(HsGroup {hs_fords = ts}) (ForD d : ds) = add (gp { hs_fords = d : ts }) ds
453 add gp@(HsGroup {hs_depds = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds
454 add gp@(HsGroup {hs_ruleds = ts})(RuleD d : ds) = add (gp { hs_ruleds = d : ts }) ds
455 add gp@(HsGroup {hs_coreds = ts})(CoreD d : ds) = add (gp { hs_coreds = d : ts }) ds
457 add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r
458 add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r
461 %************************************************************************
463 \subsection[PrefixToHS-utils]{Utilities for conversion}
465 %************************************************************************
469 -----------------------------------------------------------------------------
472 -- When parsing data declarations, we sometimes inadvertently parse
473 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
474 -- This function splits up the type application, adds any pending
475 -- arguments, and converts the type constructor back into a data constructor.
477 mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
482 split (HsAppTy t u) ts = split t (unbangedType u : ts)
483 split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
484 returnP (data_con, PrefixCon ts)
485 split _ _ = parseError "Illegal data/newtype declaration"
487 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
489 = tyConToDataCon con `thenP` \ data_con ->
490 returnP (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
492 tyConToDataCon :: RdrName -> P RdrName
494 | isTcOcc (rdrNameOcc tc)
495 = returnP (setRdrNameSpace tc srcDataName)
497 = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
499 ----------------------------------------------------------------------------
500 -- Various Syntactic Checks
502 checkInstType :: RdrNameHsType -> P RdrNameHsType
505 HsForAllTy tvs ctxt ty ->
506 checkDictTy ty [] `thenP` \ dict_ty ->
507 returnP (HsForAllTy tvs ctxt dict_ty)
509 HsParTy ty -> checkInstType ty
511 ty -> checkDictTy ty [] `thenP` \ dict_ty->
512 returnP (HsForAllTy Nothing [] dict_ty)
514 checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
518 -- Check that the name space is correct!
519 chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = returnP (IfaceTyVar tv k)
520 chk (HsTyVar tv) | isRdrTyVar tv = returnP (UserTyVar tv)
521 chk other = parseError "Type found where type variable expected"
523 checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
524 -- The header of a type or class decl should look like
525 -- (C a, D b) => T a b
533 | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs ->
535 go (HsOpTy t1 (HsTyOp tc) t2) acc
536 = checkTyVars (t1:t2:acc) `thenP` \ tvs ->
538 go (HsParTy ty) acc = go ty acc
539 go (HsAppTy t1 t2) acc = go t1 (t2:acc)
540 go other acc = parseError "Malformed LHS to type of class declaration"
542 checkContext :: RdrNameHsType -> P RdrNameContext
543 checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
546 checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way
549 checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
550 | t == getRdrName unitTyCon = returnP []
553 = checkPred t `thenP` \p ->
556 checkPred :: RdrNameHsType -> P (HsPred RdrName)
557 -- Watch out.. in ...deriving( Show )... we use checkPred on
558 -- the list of partially applied predicates in the deriving,
559 -- so there can be zero args.
560 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
564 go (HsTyVar t) args | not (isRdrTyVar t)
565 = returnP (HsClassP t args)
566 go (HsAppTy l r) args = go l (r:args)
567 go (HsParTy t) args = go t args
568 go _ _ = parseError "Illegal class assertion"
570 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
571 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
572 = returnP (mkHsDictTy t args)
573 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
574 checkDictTy (HsParTy t) args = checkDictTy t args
575 checkDictTy _ _ = parseError "Malformed context in instance header"
578 ---------------------------------------------------------------------------
579 -- Checking statements in a do-expression
580 -- We parse do { e1 ; e2 ; }
581 -- as [ExprStmt e1, ExprStmt e2]
582 -- checkDo (a) checks that the last thing is an ExprStmt
583 -- (b) transforms it to a ResultStmt
584 -- same comments apply for mdo as well
586 checkDo = checkDoMDo "a " "'do'"
587 checkMDo = checkDoMDo "an " "'mdo'"
589 checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct"
590 checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l]
591 checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
592 checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss `thenP` \ ss' ->
595 ---------------------------------------------------------------------------
596 -- Checking Patterns.
598 -- We parse patterns as expressions and check for valid patterns below,
599 -- converting the expression into a pattern at the same time.
601 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
602 checkPattern loc e = setSrcLocP loc (checkPat e [])
604 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
605 checkPatterns loc es = mapP (checkPattern loc) es
607 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
608 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
609 checkPat (HsApp f x) args =
610 checkPat x [] `thenP` \x ->
612 checkPat e [] = case e of
613 EWildPat -> returnP (WildPat placeHolderType)
614 HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x)
615 | otherwise -> returnP (VarPat x)
616 HsLit l -> returnP (LitPat l)
617 HsOverLit l -> returnP (NPatIn l Nothing)
618 ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat)
619 EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n)
620 ExprWithTySig e t -> checkPat e [] `thenP` \e ->
621 -- Pattern signatures are parsed as sigtypes,
622 -- but they aren't explicit forall points. Hence
623 -- we have to remove the implicit forall here.
625 HsForAllTy Nothing [] ty -> ty
628 returnP (SigPatIn e t')
630 -- Translate out NegApps of literals in patterns. We negate
631 -- the Integer here, and add back the call to 'negate' when
632 -- we typecheck the pattern.
633 -- NB. Negative *primitive* literals are already handled by
634 -- RdrHsSyn.mkHsNegApp
635 NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
637 OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
639 -> returnP (mkNPlusKPat n lit)
641 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
643 OpApp l op fix r -> checkPat l [] `thenP` \l ->
644 checkPat r [] `thenP` \r ->
646 HsVar c | isDataOcc (rdrNameOcc c)
647 -> returnP (ConPatIn c (InfixCon l r))
650 HsPar e -> checkPat e [] `thenP` (returnP . ParPat)
651 ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
652 returnP (ListPat ps placeHolderType)
653 ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
654 returnP (PArrPat ps placeHolderType)
656 ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
657 returnP (TuplePat ps b)
659 RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
660 returnP (ConPatIn c (RecCon fs))
662 HsType ty -> returnP (TypePat ty)
665 checkPat _ _ = patFail
667 checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
668 checkPatField (n,e) = checkPat e [] `thenP` \p ->
671 patFail = parseError "Parse error in pattern"
674 ---------------------------------------------------------------------------
675 -- Check Equation Syntax
679 -> Maybe RdrNameHsType
684 checkValDef lhs opt_sig grhss loc
685 = case isFunLhs lhs [] of
688 -> parseError ("Qualified name in function definition: " ++ showRdrName f)
690 -> checkPatterns loc es `thenP` \ps ->
691 returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
694 checkPattern loc lhs `thenP` \lhs ->
695 returnP (RdrValBinding (PatMonoBind lhs grhss loc))
702 checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc)))
703 checkValSig other ty loc = parseError "Type signature given for an expression"
705 mkSigDecls :: [Sig RdrName] -> RdrBinding
706 mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs]
709 -- A variable binding is parsed as an RdrNameFunMonoBind.
710 -- See comments with HsBinds.MonoBinds
712 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
713 isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
714 = Just (op, True, (l:r:es))
716 = case isFunLhs l es of
717 Just (op', True, j : k : es') ->
718 Just (op', True, j : OpApp k (HsVar op) fix r : es')
720 isFunLhs (HsVar f) es | not (isRdrDataCon f)
722 isFunLhs (HsApp f e) es = isFunLhs f (e:es)
723 isFunLhs (HsPar e) es@(_:_) = isFunLhs e es
724 isFunLhs _ _ = Nothing
726 ---------------------------------------------------------------------------
727 -- Miscellaneous utilities
729 checkPrecP :: Int -> P Int
730 checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i
731 | otherwise = parseError "Precedence out of range"
735 -> RdrNameHsRecordBinds
738 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
739 = returnP (RecordCon c fs)
740 mkRecConstrOrUpdate exp fs@(_:_)
741 = returnP (RecordUpd exp fs)
742 mkRecConstrOrUpdate _ _
743 = parseError "Empty record update"
745 -----------------------------------------------------------------------------
746 -- utilities for foreign declarations
748 -- supported calling conventions
750 data CallConv = CCall CCallConv -- ccall or stdcall
753 -- construct a foreign import declaration
757 -> (FastString, RdrName, RdrNameHsType)
760 mkImport (CCall cconv) safety (entity, v, ty) loc =
761 parseCImport entity cconv safety v `thenP` \importSpec ->
762 returnP $ ForD (ForeignImport v ty importSpec False loc)
763 mkImport (DNCall ) _ (entity, v, ty) loc =
764 parseDImport entity `thenP` \ spec ->
765 returnP $ ForD (ForeignImport v ty (DNImport spec) False loc)
767 -- parse the entity string of a foreign import declaration for the `ccall' or
768 -- `stdcall' calling convention'
770 parseCImport :: FastString
775 parseCImport entity cconv safety v
776 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
777 | entity == FSLIT ("dynamic") =
778 returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
779 | entity == FSLIT ("wrapper") =
780 returnP $ CImport cconv safety nilFS nilFS CWrapper
781 | otherwise = parse0 (unpackFS entity)
783 -- using the static keyword?
784 parse0 (' ': rest) = parse0 rest
785 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
786 parse0 rest = parse1 rest
787 -- check for header file name
788 parse1 "" = parse4 "" nilFS False nilFS
789 parse1 (' ':rest) = parse1 rest
790 parse1 str@('&':_ ) = parse2 str nilFS
791 parse1 str@('[':_ ) = parse3 str nilFS False
793 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
794 | otherwise = parse4 str nilFS False nilFS
796 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
797 -- check for address operator (indicating a label import)
798 parse2 "" header = parse4 "" header False nilFS
799 parse2 (' ':rest) header = parse2 rest header
800 parse2 ('&':rest) header = parse3 rest header True
801 parse2 str@('[':_ ) header = parse3 str header False
802 parse2 str header = parse4 str header False nilFS
803 -- check for library object name
804 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
805 parse3 ('[':rest) header isLbl =
806 case break (== ']') rest of
807 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
808 _ -> parseError "Missing ']' in entity"
809 parse3 str header isLbl = parse4 str header isLbl nilFS
810 -- check for name of C function
811 parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib
812 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
813 parse4 str header isLbl lib
814 | all (== ' ') rest = build (mkFastString first) header isLbl lib
815 | otherwise = parseError "Malformed entity string"
817 (first, rest) = break (== ' ') str
819 build cid header False lib = returnP $
820 CImport cconv safety header lib (CFunction (StaticTarget cid))
821 build cid header True lib = returnP $
822 CImport cconv safety header lib (CLabel cid )
825 -- Unravel a dotnet spec string.
827 parseDImport :: FastString -> P DNCallSpec
828 parseDImport entity = parse0 comps
830 comps = words (unpackFS entity)
834 | x == "static" = parse1 True xs
835 | otherwise = parse1 False (x:xs)
838 parse1 isStatic (x:xs)
839 | x == "method" = parse2 isStatic DNMethod xs
840 | x == "field" = parse2 isStatic DNField xs
841 | x == "ctor" = parse2 isStatic DNConstructor xs
842 parse1 isStatic xs = parse2 isStatic DNMethod xs
845 parse2 isStatic kind (('[':x):xs) =
848 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
849 parse2 isStatic kind xs = parse3 isStatic kind "" xs
851 parse3 isStatic kind assem [x] =
852 returnP (DNCallSpec isStatic kind assem x
853 -- these will be filled in once known.
854 (error "FFI-dotnet-args")
855 (error "FFI-dotnet-result"))
856 parse3 _ _ _ _ = d'oh
858 d'oh = parseError "Malformed entity string"
860 -- construct a foreign export declaration
863 -> (FastString, RdrName, RdrNameHsType)
866 mkExport (CCall cconv) (entity, v, ty) loc = returnP $
867 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
869 entity' | nullFastString entity = mkExtName v
871 mkExport DNCall (entity, v, ty) loc =
872 parseError "Foreign export is not yet supported for .NET"
874 -- Supplying the ext_name in a foreign decl is optional; if it
875 -- isn't there, the Haskell name is assumed. Note that no transformation
876 -- of the Haskell name is then performed, so if you foreign export (++),
877 -- it's external name will be "++". Too bad; it's important because we don't
878 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
879 -- (This is why we use occNameUserString.)
881 mkExtName :: RdrName -> CLabelString
882 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
884 -- ---------------------------------------------------------------------------
885 -- Make the export list for an interface
887 mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
888 mkIfaceExports decls = map getExport decls
889 where getExport d = case d of
890 TyData{} -> tc_export
891 ClassDecl{} -> tc_export
894 tc_export = AvailTC (rdrNameOcc (tcdName d))
895 (map (rdrNameOcc.fst) (tyClDeclNames d))
896 var_export = Avail (rdrNameOcc (tcdName d))
900 -----------------------------------------------------------------------------
904 showRdrName :: RdrName -> String
905 showRdrName r = showSDoc (ppr r)
907 parseError :: String -> P a
909 getSrcLocP `thenP` \ loc ->
910 failMsgP (hcat [ppr loc, text ": ", text s])