2 % (c) The University of Glasgow, 1996-2003
4 Functions over HsSyn specialised to RdrName.
9 extractHsRhoRdrTyVars, extractGenericPatTyVars,
11 mkHsOpApp, mkClassDecl,
12 mkHsNegApp, mkHsIntegral, mkHsFractional,
14 mkTyData, mkPrefixCon, mkRecCon,
15 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
23 -- Stuff to do with Foreign declarations
25 , mkImport -- CallConv -> Safety
26 -- -> (FastString, RdrName, RdrNameHsType)
28 , mkExport -- CallConv
29 -- -> (FastString, RdrName, RdrNameHsType)
31 , mkExtName -- RdrName -> CLabelString
33 -- Bunch of functions in the parser monad for
34 -- checking and constructing values
35 , checkPrecP -- Int -> P Int
36 , checkContext -- HsType -> P HsContext
37 , checkPred -- HsType -> P HsPred
38 , checkTyClHdr -- HsType -> (name,[tyvar])
39 , checkInstType -- HsType -> P HsType
40 , checkPattern -- HsExp -> P HsPat
41 , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
42 , checkDo -- [Stmt] -> P [Stmt]
43 , checkMDo -- [Stmt] -> P [Stmt]
44 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
45 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
46 , parseError -- String -> Pa
49 #include "HsVersions.h"
51 import HsSyn -- Lots of it
53 import Packages ( PackageIdH(..) )
54 import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache,
55 Dependencies(..), IsBootInterface, noDependencies )
56 import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) )
57 import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
58 isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
59 setRdrNameSpace, rdrNameModule )
60 import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
61 import Lexer ( P, failSpanMsgP )
62 import Kind ( liftedTypeKind )
63 import HscTypes ( GenAvailInfo(..) )
64 import TysWiredIn ( unitTyCon )
65 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
66 DNCallSpec(..), DNKind(..), CLabelString )
67 import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
68 occNameUserString, isValOcc )
69 import BasicTypes ( initialVersion, StrictnessMark(..) )
70 import Module ( Module )
72 import OrdList ( OrdList, fromOL )
73 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
78 import List ( isSuffixOf, nubBy )
82 %************************************************************************
84 \subsection{A few functions over HsSyn at RdrName}
86 %************************************************************************
88 extractHsTyRdrNames finds the free variables of a HsType
89 It's used when making the for-alls explicit.
92 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
93 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
95 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
96 -- This one takes the context and tau-part of a
97 -- sigma type and returns their free type variables
98 extractHsRhoRdrTyVars ctxt ty
99 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
101 extract_lctxt ctxt acc = foldr (extract_pred.unLoc) acc (unLoc ctxt)
103 extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
104 extract_pred (HsIParam n ty) acc = extract_lty ty acc
106 extract_lty (L loc (HsTyVar tv)) acc
107 | isRdrTyVar tv = L loc tv : acc
109 extract_lty ty acc = extract_ty (unLoc ty) acc
111 extract_ty (HsBangTy _ ty) acc = extract_lty ty acc
112 extract_ty (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
113 extract_ty (HsListTy ty) acc = extract_lty ty acc
114 extract_ty (HsPArrTy ty) acc = extract_lty ty acc
115 extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys
116 extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
117 extract_ty (HsPredTy p) acc = extract_pred p acc
118 extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
119 extract_ty (HsParTy ty) acc = extract_lty ty acc
120 extract_ty (HsNumTy num) acc = acc
121 extract_ty (HsSpliceTy _) acc = acc -- Type splices mention no type variables
122 extract_ty (HsKindSig ty k) acc = extract_lty ty acc
123 extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
124 extract_ty (HsForAllTy exp tvs cx ty)
125 acc = (filter ((`notElem` locals) . unLoc) $
126 extract_lctxt cx (extract_lty ty [])) ++ acc
128 locals = hsLTyVarNames tvs
130 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
131 -- Get the type variables out of the type patterns in a bunch of
132 -- possibly-generic bindings in a class declaration
133 extractGenericPatTyVars binds
134 = nubBy eqLocated (foldrBag get [] binds)
136 get (L _ (FunBind _ _ (MatchGroup ms _))) acc = foldr (get_m.unLoc) acc ms
139 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
140 get_m other acc = acc
144 %************************************************************************
146 \subsection{Construction functions for Rdr stuff}
148 %************************************************************************
150 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
151 by deriving them from the name of the class. We fill in the names for the
152 tycon and datacon corresponding to the class, by deriving them from the
153 name of the class itself. This saves recording the names in the interface
154 file (which would be equally good).
156 Similarly for mkConDecl, mkClassOpSig and default-method names.
158 *** See "THE NAMING STORY" in HsDecls ****
161 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
162 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
168 mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv
169 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
170 tcdTyVars = tyvars, tcdCons = data_cons,
171 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
175 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
176 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
177 -- can't take an unboxed arg. But that is exactly what it will see when
178 -- we write "-3#". So we have to do the negation right now!
179 mkHsNegApp (L loc e) = f e
180 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
181 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
182 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
183 f expr = NegApp (L loc e) placeHolderName
186 %************************************************************************
190 %************************************************************************
192 mkBootIface, and its deeply boring helper functions, have two purposes:
194 a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
195 an hi-boot file, and interfaces consist of the latter
197 b) Convert unqualifed names from the "current module" to qualified Orig
200 foo :: GHC.Base.Int -> GHC.Base.Int
202 This.foo :: GHC.Base.Int -> GHC.Base.Int
204 It assumes that everything is well kinded, of course. Failure causes a
205 fatal error using pgmError, rather than a monadic error. You're supposed
206 to get hi-boot files right!
210 mkBootIface :: Module -> ([(Module, IsBootInterface)], [HsDecl RdrName]) -> ModIface
211 -- Make the ModIface for a hi-boot file
212 -- The decls are of very limited form
213 -- The package will be filled in later (see LoadIface.readIface)
214 mkBootIface mod (imports, decls)
215 = (emptyModIface HomePackage{-fill in later-} mod) {
217 mi_deps = noDependencies { dep_mods = imports },
218 mi_exports = [(mod, map mk_export decls')],
219 mi_decls = decls_w_vers,
220 mi_ver_fn = mkIfaceVerCache decls_w_vers }
222 decls' = map hsIfaceDecl decls
223 decls_w_vers = repeat initialVersion `zip` decls'
225 -- hi-boot declarations don't (currently)
226 -- expose constructors or class methods
227 mk_export decl | isValOcc occ = Avail occ
228 | otherwise = AvailTC occ [occ]
233 hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
234 -- Change to Iface syntax, and replace unqualified names with
235 -- qualified Orig names from this module. Reason: normal
236 -- iface files have everything fully qualified, so it's convenient
237 -- for hi-boot files to look the same
239 -- NB: no constructors or class ops to worry about
240 hsIfaceDecl (SigD (Sig name ty))
241 = IfaceId { ifName = rdrNameOcc (unLoc name),
242 ifType = hsIfaceLType ty,
245 hsIfaceDecl (TyClD decl@(ClassDecl {}))
246 = IfaceClass { ifName = rdrNameOcc (tcdName decl),
247 ifTyVars = hsIfaceTvs (tcdTyVars decl),
248 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
249 ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
250 ifSigs = [], -- Is this right??
251 ifRec = NonRecursive, ifVrcs = [] }
253 hsIfaceDecl (TyClD decl@(TySynonym {}))
254 = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
255 ifTyVars = hsIfaceTvs (tcdTyVars decl),
256 ifSynRhs = hsIfaceLType (tcdSynRhs decl),
259 hsIfaceDecl (TyClD decl@(TyData {}))
260 = IfaceData { ifName = rdrNameOcc (tcdName decl),
262 ifCons = hsIfaceCons tvs decl,
263 ifRec = Recursive, -- Hi-boot decls are always loop-breakers
264 ifVrcs = [], ifGeneric = False }
265 -- I'm not sure that [] is right for ifVrcs, but
266 -- since we don't use them I'm not going to fiddle
268 tvs = hsIfaceTvs (tcdTyVars decl)
270 hsIfaceDecl decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
272 hsIfaceCons :: [IfaceTvBndr] -> TyClDecl RdrName -> IfaceConDecls
273 hsIfaceCons tvs decl@(TyData {tcdCtxt = L _ stupid_ctxt})
274 | not (null stupid_ctxt) -- Keep it simple: no data type contexts
275 -- Else we'll have to do "thinning"; sigh
276 = pprPgmError "Can't do data type contexts in hi-boot file:" (ppr decl)
278 hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = []})
279 = -- data T a, meaning "constructors unspecified",
280 IfAbstractTyCon -- not "no constructors"
282 hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = cons})
283 = IfDataTyCon Nothing (map (hsIfaceCon tvs . unLoc) cons)
285 hsIfaceCons tvs (TyData {tcdND = NewType, tcdCons = [con]})
286 = IfNewTyCon (hsIfaceCon tvs (unLoc con))
288 hsIfaceCons tvs decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
291 hsIfaceCon :: [IfaceTvBndr] -> ConDecl RdrName -> IfaceConDecl
292 hsIfaceCon tvs (ConDecl lname ex_tvs ex_ctxt details)
293 | null ex_tvs && null (unLoc ex_ctxt)
294 = IfVanillaCon { ifConOcc = get_occ lname,
295 ifConInfix = is_infix,
296 ifConArgTys = map hsIfaceLType args,
297 ifConStricts = map (hsStrictMark . getBangStrictness) args,
300 = IfGadtCon { ifConOcc = get_occ lname,
301 ifConTyVars = tvs ++ hsIfaceTvs ex_tvs,
302 ifConCtxt = hsIfaceCtxt (unLoc ex_ctxt),
303 ifConArgTys = map hsIfaceLType args,
304 ifConResTys = map (IfaceTyVar . fst) tvs,
305 ifConStricts = map (hsStrictMark . getBangStrictness) args }
306 | otherwise = pprPgmError "Fields illegal in existential" (ppr (unLoc lname))
308 (is_infix, args, flds) = case details of
309 PrefixCon args -> (False, args, [])
310 InfixCon a1 a2 -> (True, [a1,a2], [])
311 RecCon fs -> (False, map snd fs, map (get_occ . fst) fs)
312 get_occ lname = rdrNameOcc (unLoc lname)
314 hsIfaceCon _tvs (GadtDecl lname con_ty) -- Not yet
315 = pprPgmError "Can't use GADTs in hi-boot files (yet)" (ppr (unLoc lname))
317 hsStrictMark :: HsBang -> StrictnessMark
318 -- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
319 -- but in an hi-boot file it's interpreted as the Truth!
320 hsStrictMark HsNoBang = NotMarkedStrict
321 hsStrictMark HsStrict = MarkedStrict
322 hsStrictMark HsUnbox = MarkedUnboxed
324 hsIfaceName rdr_name -- Qualify unqualifed occurrences
325 -- with the module name
326 | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
327 | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
329 hsIfaceLType :: LHsType RdrName -> IfaceType
330 hsIfaceLType = hsIfaceType . unLoc
332 hsIfaceType :: HsType RdrName -> IfaceType
333 hsIfaceType (HsForAllTy exp tvs cxt ty)
334 = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
336 rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
337 tau = hsIfaceLType ty
339 Explicit -> map unLoc tvs
340 Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
342 hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
343 hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
344 hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
345 hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t]
346 hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
347 hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
348 hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
349 hsIfaceType (HsParTy t) = hsIfaceLType t
350 hsIfaceType (HsBangTy _ t) = hsIfaceLType t
351 hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
352 hsIfaceType (HsKindSig t _) = hsIfaceLType t
353 hsIfaceType ty = pprPanic "hsIfaceType" (ppr ty)
354 -- HsNumTy, HsSpliceTy
357 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
360 hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
361 hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
364 hsIfaceLPred :: LHsPred RdrName -> IfacePredType
365 hsIfaceLPred = hsIfacePred . unLoc
367 hsIfacePred :: HsPred RdrName -> IfacePredType
368 hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
369 hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
372 hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
373 hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
374 hs_tc_app (HsTyVar n) args
375 | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
376 | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
377 hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
380 hsIfaceTvs :: [LHsTyVarBndr RdrName] -> [IfaceTvBndr]
381 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
384 hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind)
385 hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
388 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
389 hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
393 %************************************************************************
395 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
397 %************************************************************************
399 Function definitions are restructured here. Each is assumed to be recursive
400 initially, and non recursive definitions are discovered by the dependency
405 -- | Groups together bindings for a single function
406 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
407 cvTopDecls decls = go (fromOL decls)
409 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
411 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
412 where (L l' b', ds') = getMonoBind (L l b) ds
413 go (d : ds) = d : go ds
415 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
417 = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
418 HsBindGroup mbs sigs Recursive -- just one big group for now
421 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
422 -> (Bag (LHsBind RdrName), [LSig RdrName])
423 -- Input decls contain just value bindings and signatures
424 cvBindsAndSigs fb = go (fromOL fb)
426 go [] = (emptyBag, [])
427 go (L l (SigD s) : ds) = (bs, L l s : ss)
428 where (bs,ss) = go ds
429 go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
430 where (b',ds') = getMonoBind (L l b) ds
433 -----------------------------------------------------------------------------
434 -- Group function bindings into equation groups
436 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
437 -> (LHsBind RdrName, [LHsDecl RdrName])
438 -- Suppose (b',ds') = getMonoBind b ds
439 -- ds is a *reversed* list of parsed bindings
440 -- b is a MonoBinds that has just been read off the front
442 -- Then b' is the result of grouping more equations from ds that
443 -- belong with b into a single MonoBinds, and ds' is the depleted
444 -- list of parsed bindings.
446 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
449 getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds
453 go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds)
454 | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
455 where loc = combineSrcSpans loc1 loc2
457 = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds)
458 -- reverse the final matches, to get it back in the right order
460 getMonoBind bind binds = (bind, binds)
462 has_args ((L _ (Match args _ _)) : _) = not (null args)
463 -- Don't group together FunBinds if they have
464 -- no arguments. This is necessary now that variable bindings
465 -- with no arguments are now treated as FunBinds rather
466 -- than pattern bindings (tests/rename/should_fail/rnfail002).
470 emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
471 hs_tyclds = [], hs_instds = [],
472 hs_fixds = [], hs_defds = [], hs_fords = [],
473 hs_depds = [] ,hs_ruleds = [] }
475 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
476 findSplice ds = addl emptyGroup ds
478 mkGroup :: [LHsDecl a] -> HsGroup a
479 mkGroup ds = addImpDecls emptyGroup ds
481 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
482 -- The decls are imported, and should not have a splice
483 addImpDecls group decls = case addl group decls of
484 (group', Nothing) -> group'
485 other -> panic "addImpDecls"
487 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
488 -- This stuff reverses the declarations (again) but it doesn't matter
491 addl gp [] = (gp, Nothing)
492 addl gp (L l d : ds) = add gp l d ds
495 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
496 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
498 add gp l (SpliceD e) ds = (gp, Just (e, ds))
500 -- Class declarations: pull out the fixity signatures to the top
501 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
503 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
504 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
506 addl (gp { hs_tyclds = L l d : ts }) ds
508 -- Signatures: fixity sigs go a different place than all others
509 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
510 = addl (gp {hs_fixds = L l f : ts}) ds
511 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
512 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
514 -- Value declarations: use add_bind
515 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
516 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
518 -- The rest are routine
519 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
520 = addl (gp { hs_instds = L l d : ts }) ds
521 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
522 = addl (gp { hs_defds = L l d : ts }) ds
523 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
524 = addl (gp { hs_fords = L l d : ts }) ds
525 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
526 = addl (gp { hs_depds = L l d : ts }) ds
527 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
528 = addl (gp { hs_ruleds = L l d : ts }) ds
530 add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r]
531 add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r]
534 %************************************************************************
536 \subsection[PrefixToHS-utils]{Utilities for conversion}
538 %************************************************************************
542 -----------------------------------------------------------------------------
545 -- When parsing data declarations, we sometimes inadvertently parse
546 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
547 -- This function splits up the type application, adds any pending
548 -- arguments, and converts the type constructor back into a data constructor.
550 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
551 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
555 split (L _ (HsAppTy t u)) ts = split t (u : ts)
556 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
557 return (data_con, PrefixCon ts)
558 split (L l _) _ = parseError l "parse error in data/newtype declaration"
560 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
561 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
562 mkRecCon (L loc con) fields
563 = do data_con <- tyConToDataCon loc con
564 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
566 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
567 tyConToDataCon loc tc
568 | isTcOcc (rdrNameOcc tc)
569 = return (L loc (setRdrNameSpace tc srcDataName))
571 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
573 ----------------------------------------------------------------------------
574 -- Various Syntactic Checks
576 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
577 checkInstType (L l t)
579 HsForAllTy exp tvs ctxt ty -> do
580 dict_ty <- checkDictTy ty
581 return (L l (HsForAllTy exp tvs ctxt dict_ty))
583 HsParTy ty -> checkInstType ty
585 ty -> do dict_ty <- checkDictTy (L l ty)
586 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
588 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
592 -- Check that the name space is correct!
593 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
594 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
595 chk (L l (HsTyVar tv))
596 | isRdrTyVar tv = return (L l (UserTyVar tv))
598 = parseError l "Type found where type variable expected"
600 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
601 -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
602 -- The header of a type or class decl should look like
603 -- (C a, D b) => T a b
607 checkTyClHdr (L l cxt) ty
608 = do (tc, tvs) <- gol ty []
610 return (L l cxt, tc, tvs)
612 gol (L l ty) acc = go l ty acc
614 go l (HsTyVar tc) acc
615 | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
617 go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
619 go l (HsParTy ty) acc = gol ty acc
620 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
621 go l other acc = parseError l "Malformed LHS to type of class declaration"
623 -- The predicates in a type or class decl must all
624 -- be HsClassPs. They need not all be type variables,
625 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
626 chk_pred (L l (HsClassP _ args)) = return ()
628 = parseError l "Malformed context in type or class declaration"
631 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
635 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
636 = do ctx <- mapM checkPred ts
639 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
642 check (HsTyVar t) -- Empty context shows up as a unit type ()
643 | t == getRdrName unitTyCon = return (L l [])
646 = do p <- checkPred (L l t)
650 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
651 -- Watch out.. in ...deriving( Show )... we use checkPred on
652 -- the list of partially applied predicates in the deriving,
653 -- so there can be zero args.
654 checkPred (L spn (HsPredTy (HsIParam n ty)))
655 = return (L spn (HsIParam n ty))
659 checkl (L l ty) args = check l ty args
661 check loc (HsTyVar t) args | not (isRdrTyVar t)
662 = return (L spn (HsClassP t args))
663 check loc (HsAppTy l r) args = checkl l (r:args)
664 check loc (HsParTy t) args = checkl t args
665 check loc _ _ = parseError loc "malformed class assertion"
667 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
668 checkDictTy (L spn ty) = check ty []
670 check (HsTyVar t) args | not (isRdrTyVar t)
671 = return (L spn (HsPredTy (HsClassP t args)))
672 check (HsAppTy l r) args = check (unLoc l) (r:args)
673 check (HsParTy t) args = check (unLoc t) args
674 check _ _ = parseError spn "Malformed context in instance header"
676 ---------------------------------------------------------------------------
677 -- Checking statements in a do-expression
678 -- We parse do { e1 ; e2 ; }
679 -- as [ExprStmt e1, ExprStmt e2]
680 -- checkDo (a) checks that the last thing is an ExprStmt
681 -- (b) transforms it to a ResultStmt
682 -- same comments apply for mdo as well
684 checkDo = checkDoMDo "a " "'do'"
685 checkMDo = checkDoMDo "an " "'mdo'"
687 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
688 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
689 checkDoMDo pre nm loc ss = do
692 check [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
693 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
694 " construct must be an expression")
699 -- -------------------------------------------------------------------------
700 -- Checking Patterns.
702 -- We parse patterns as expressions and check for valid patterns below,
703 -- converting the expression into a pattern at the same time.
705 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
706 checkPattern e = checkLPat e
708 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
709 checkPatterns es = mapM checkPattern es
711 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
712 checkLPat e@(L l _) = checkPat l e []
714 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
715 checkPat loc (L l (HsVar c)) args
716 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
717 checkPat loc (L _ (HsApp f x)) args = do
719 checkPat loc f (x:args)
720 checkPat loc (L _ e) [] = do
723 checkPat loc pat _some_args
726 checkAPat loc e = case e of
727 EWildPat -> return (WildPat placeHolderType)
728 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
730 | otherwise -> return (VarPat x)
731 HsLit l -> return (LitPat l)
733 -- Overloaded numeric patterns (e.g. f 0 x = x)
734 -- Negation is recorded separately, so that the literal is zero or +ve
735 -- NB. Negative *primitive* literals are already handled by
736 -- RdrHsSyn.mkHsNegApp
737 HsOverLit pos_lit -> return (NPatIn pos_lit Nothing)
738 NegApp (L _ (HsOverLit pos_lit)) _
739 -> return (NPatIn pos_lit (Just placeHolderName))
741 ELazyPat e -> checkLPat e >>= (return . LazyPat)
742 EAsPat n e -> checkLPat e >>= (return . AsPat n)
743 ExprWithTySig e t -> checkLPat e >>= \e ->
744 -- Pattern signatures are parsed as sigtypes,
745 -- but they aren't explicit forall points. Hence
746 -- we have to remove the implicit forall here.
748 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
751 return (SigPatIn e t')
754 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
755 (L _ (HsOverLit lit@(HsIntegral _ _)))
757 -> return (mkNPlusKPat (L nloc n) lit)
759 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
761 OpApp l op fix r -> checkLPat l >>= \l ->
762 checkLPat r >>= \r ->
764 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
765 -> return (ConPatIn (L cl c) (InfixCon l r))
768 HsPar e -> checkLPat e >>= (return . ParPat)
769 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
770 return (ListPat ps placeHolderType)
771 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
772 return (PArrPat ps placeHolderType)
774 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
775 return (TuplePat ps b)
777 RecordCon c fs -> mapM checkPatField fs >>= \fs ->
778 return (ConPatIn c (RecCon fs))
780 HsType ty -> return (TypePat ty)
783 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
784 checkPatField (n,e) = do
788 patFail loc = parseError loc "Parse error in pattern"
791 ---------------------------------------------------------------------------
792 -- Check Equation Syntax
796 -> Maybe (LHsType RdrName)
797 -> Located (GRHSs RdrName)
798 -> P (HsBind RdrName)
800 checkValDef lhs opt_sig (L rhs_span grhss)
801 | Just (f,inf,es) <- isFunLhs lhs []
802 = if isQual (unLoc f)
803 then parseError (getLoc f) ("Qualified name in function definition: " ++
804 showRdrName (unLoc f))
805 else do ps <- checkPatterns es
806 let match_span = combineSrcSpans (getLoc lhs) rhs_span
807 return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)]))
808 -- The span of the match covers the entire equation.
809 -- That isn't quite right, but it'll do for now.
811 lhs <- checkPattern lhs
812 return (PatBind lhs grhss placeHolderType)
818 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
819 checkValSig (L l other) ty
820 = parseError l "Type signature given for an expression"
822 -- A variable binding is parsed as a FunBind.
824 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
825 -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
826 isFunLhs (L loc e) = isFunLhs' loc e
828 isFunLhs' loc (HsVar f) es
829 | not (isRdrDataCon f) = Just (L loc f, False, es)
830 isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es)
831 isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es
832 isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
833 | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
835 case isFunLhs l es of
836 Just (op', True, j : k : es') ->
838 j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
840 isFunLhs' _ _ _ = Nothing
842 ---------------------------------------------------------------------------
843 -- Miscellaneous utilities
845 checkPrecP :: Located Int -> P Int
847 | 0 <= i && i <= maxPrecedence = return i
848 | otherwise = parseError l "Precedence out of range"
853 -> HsRecordBinds RdrName
854 -> P (HsExpr RdrName)
856 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
857 = return (RecordCon (L l c) fs)
858 mkRecConstrOrUpdate exp loc fs@(_:_)
859 = return (RecordUpd exp fs)
860 mkRecConstrOrUpdate _ loc []
861 = parseError loc "Empty record update"
863 -----------------------------------------------------------------------------
864 -- utilities for foreign declarations
866 -- supported calling conventions
868 data CallConv = CCall CCallConv -- ccall or stdcall
871 -- construct a foreign import declaration
875 -> (Located FastString, Located RdrName, LHsType RdrName)
876 -> P (HsDecl RdrName)
877 mkImport (CCall cconv) safety (entity, v, ty) = do
878 importSpec <- parseCImport entity cconv safety v
879 return (ForD (ForeignImport v ty importSpec False))
880 mkImport (DNCall ) _ (entity, v, ty) = do
881 spec <- parseDImport entity
882 return $ ForD (ForeignImport v ty (DNImport spec) False)
884 -- parse the entity string of a foreign import declaration for the `ccall' or
885 -- `stdcall' calling convention'
887 parseCImport :: Located FastString
892 parseCImport (L loc entity) cconv safety v
893 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
894 | entity == FSLIT ("dynamic") =
895 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
896 | entity == FSLIT ("wrapper") =
897 return $ CImport cconv safety nilFS nilFS CWrapper
898 | otherwise = parse0 (unpackFS entity)
900 -- using the static keyword?
901 parse0 (' ': rest) = parse0 rest
902 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
903 parse0 rest = parse1 rest
904 -- check for header file name
905 parse1 "" = parse4 "" nilFS False nilFS
906 parse1 (' ':rest) = parse1 rest
907 parse1 str@('&':_ ) = parse2 str nilFS
908 parse1 str@('[':_ ) = parse3 str nilFS False
910 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
911 | otherwise = parse4 str nilFS False nilFS
913 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
914 -- check for address operator (indicating a label import)
915 parse2 "" header = parse4 "" header False nilFS
916 parse2 (' ':rest) header = parse2 rest header
917 parse2 ('&':rest) header = parse3 rest header True
918 parse2 str@('[':_ ) header = parse3 str header False
919 parse2 str header = parse4 str header False nilFS
920 -- check for library object name
921 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
922 parse3 ('[':rest) header isLbl =
923 case break (== ']') rest of
924 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
925 _ -> parseError loc "Missing ']' in entity"
926 parse3 str header isLbl = parse4 str header isLbl nilFS
927 -- check for name of C function
928 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
929 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
930 parse4 str header isLbl lib
931 | all (== ' ') rest = build (mkFastString first) header isLbl lib
932 | otherwise = parseError loc "Malformed entity string"
934 (first, rest) = break (== ' ') str
936 build cid header False lib = return $
937 CImport cconv safety header lib (CFunction (StaticTarget cid))
938 build cid header True lib = return $
939 CImport cconv safety header lib (CLabel cid )
942 -- Unravel a dotnet spec string.
944 parseDImport :: Located FastString -> P DNCallSpec
945 parseDImport (L loc entity) = parse0 comps
947 comps = words (unpackFS entity)
951 | x == "static" = parse1 True xs
952 | otherwise = parse1 False (x:xs)
955 parse1 isStatic (x:xs)
956 | x == "method" = parse2 isStatic DNMethod xs
957 | x == "field" = parse2 isStatic DNField xs
958 | x == "ctor" = parse2 isStatic DNConstructor xs
959 parse1 isStatic xs = parse2 isStatic DNMethod xs
962 parse2 isStatic kind (('[':x):xs) =
965 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
966 parse2 isStatic kind xs = parse3 isStatic kind "" xs
968 parse3 isStatic kind assem [x] =
969 return (DNCallSpec isStatic kind assem x
970 -- these will be filled in once known.
971 (error "FFI-dotnet-args")
972 (error "FFI-dotnet-result"))
973 parse3 _ _ _ _ = d'oh
975 d'oh = parseError loc "Malformed entity string"
977 -- construct a foreign export declaration
980 -> (Located FastString, Located RdrName, LHsType RdrName)
981 -> P (HsDecl RdrName)
982 mkExport (CCall cconv) (L loc entity, v, ty) = return $
983 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
985 entity' | nullFastString entity = mkExtName (unLoc v)
987 mkExport DNCall (L loc entity, v, ty) =
988 parseError (getLoc v){-TODO: not quite right-}
989 "Foreign export is not yet supported for .NET"
991 -- Supplying the ext_name in a foreign decl is optional; if it
992 -- isn't there, the Haskell name is assumed. Note that no transformation
993 -- of the Haskell name is then performed, so if you foreign export (++),
994 -- it's external name will be "++". Too bad; it's important because we don't
995 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
996 -- (This is why we use occNameUserString.)
998 mkExtName :: RdrName -> CLabelString
999 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
1003 -----------------------------------------------------------------------------
1007 showRdrName :: RdrName -> String
1008 showRdrName r = showSDoc (ppr r)
1010 parseError :: SrcSpan -> String -> P a
1011 parseError span s = failSpanMsgP span s