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 HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache,
55 import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) )
56 import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
57 isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
58 setRdrNameSpace, rdrNameModule )
59 import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
60 import Lexer ( P, failSpanMsgP )
61 import Kind ( liftedTypeKind )
62 import HscTypes ( GenAvailInfo(..) )
63 import TysWiredIn ( unitTyCon )
64 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
65 DNCallSpec(..), DNKind(..), CLabelString )
66 import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
67 occNameUserString, isValOcc )
68 import BasicTypes ( initialVersion, StrictnessMark(..) )
69 import Module ( Module )
71 import OrdList ( OrdList, fromOL )
72 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
77 import List ( isSuffixOf, nubBy )
81 %************************************************************************
83 \subsection{A few functions over HsSyn at RdrName}
85 %************************************************************************
87 extractHsTyRdrNames finds the free variables of a HsType
88 It's used when making the for-alls explicit.
91 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
92 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
94 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
95 -- This one takes the context and tau-part of a
96 -- sigma type and returns their free type variables
97 extractHsRhoRdrTyVars ctxt ty
98 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
100 extract_lctxt ctxt acc = foldr (extract_pred.unLoc) acc (unLoc ctxt)
102 extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
103 extract_pred (HsIParam n ty) acc = extract_lty ty acc
105 extract_lty (L loc (HsTyVar tv)) acc
106 | isRdrTyVar tv = L loc tv : acc
108 extract_lty ty acc = extract_ty (unLoc ty) acc
110 extract_ty (HsBangTy _ ty) acc = extract_lty ty acc
111 extract_ty (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
112 extract_ty (HsListTy ty) acc = extract_lty ty acc
113 extract_ty (HsPArrTy ty) acc = extract_lty ty acc
114 extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys
115 extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
116 extract_ty (HsPredTy p) acc = extract_pred p acc
117 extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
118 extract_ty (HsParTy ty) acc = extract_lty ty acc
119 extract_ty (HsNumTy num) acc = acc
120 extract_ty (HsSpliceTy _) acc = acc -- Type splices mention no type variables
121 extract_ty (HsKindSig ty k) acc = extract_lty ty acc
122 extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
123 extract_ty (HsForAllTy exp tvs cx ty)
124 acc = (filter ((`notElem` locals) . unLoc) $
125 extract_lctxt cx (extract_lty ty [])) ++ acc
127 locals = hsLTyVarNames tvs
129 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
130 -- Get the type variables out of the type patterns in a bunch of
131 -- possibly-generic bindings in a class declaration
132 extractGenericPatTyVars binds
133 = nubBy eqLocated (foldrBag get [] binds)
135 get (L _ (FunBind _ _ (MatchGroup ms _))) acc = foldr (get_m.unLoc) acc ms
138 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
139 get_m other acc = acc
143 %************************************************************************
145 \subsection{Construction functions for Rdr stuff}
147 %************************************************************************
149 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
150 by deriving them from the name of the class. We fill in the names for the
151 tycon and datacon corresponding to the class, by deriving them from the
152 name of the class itself. This saves recording the names in the interface
153 file (which would be equally good).
155 Similarly for mkConDecl, mkClassOpSig and default-method names.
157 *** See "THE NAMING STORY" in HsDecls ****
160 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
161 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
167 mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv
168 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
169 tcdTyVars = tyvars, tcdCons = data_cons,
170 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
174 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
175 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
176 -- can't take an unboxed arg. But that is exactly what it will see when
177 -- we write "-3#". So we have to do the negation right now!
178 mkHsNegApp (L loc e) = f e
179 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
180 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
181 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
182 f expr = NegApp (L loc e) placeHolderName
185 %************************************************************************
189 %************************************************************************
191 mkBootIface, and its deeply boring helper functions, have two purposes:
193 a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
194 an hi-boot file, and interfaces consist of the latter
196 b) Convert unqualifed names from the "current module" to qualified Orig
199 foo :: GHC.Base.Int -> GHC.Base.Int
201 This.foo :: GHC.Base.Int -> GHC.Base.Int
203 It assumes that everything is well kinded, of course. Failure causes a
204 fatal error using pgmError, rather than a monadic error. You're supposed
205 to get hi-boot files right!
209 mkBootIface :: Module -> [HsDecl RdrName] -> ModIface
210 -- Make the ModIface for a hi-boot file
211 -- The decls are of very limited form
212 -- The package will be filled in later (see LoadIface.readIface)
213 mkBootIface mod decls
214 = (emptyModIface ThisPackage{-fill in later-} mod) {
216 mi_exports = [(mod, map mk_export decls')],
217 mi_decls = decls_w_vers,
218 mi_ver_fn = mkIfaceVerCache decls_w_vers }
220 decls' = map hsIfaceDecl decls
221 decls_w_vers = repeat initialVersion `zip` decls'
223 -- hi-boot declarations don't (currently)
224 -- expose constructors or class methods
225 mk_export decl | isValOcc occ = Avail occ
226 | otherwise = AvailTC occ [occ]
231 hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
232 -- Change to Iface syntax, and replace unqualified names with
233 -- qualified Orig names from this module. Reason: normal
234 -- iface files have everything fully qualified, so it's convenient
235 -- for hi-boot files to look the same
237 -- NB: no constructors or class ops to worry about
238 hsIfaceDecl (SigD (Sig name ty))
239 = IfaceId { ifName = rdrNameOcc (unLoc name),
240 ifType = hsIfaceLType ty,
243 hsIfaceDecl (TyClD decl@(ClassDecl {}))
244 = IfaceClass { ifName = rdrNameOcc (tcdName decl),
245 ifTyVars = hsIfaceTvs (tcdTyVars decl),
246 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
247 ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
248 ifSigs = [], -- Is this right??
249 ifRec = NonRecursive, ifVrcs = [] }
251 hsIfaceDecl (TyClD decl@(TySynonym {}))
252 = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
253 ifTyVars = hsIfaceTvs (tcdTyVars decl),
254 ifSynRhs = hsIfaceLType (tcdSynRhs decl),
257 hsIfaceDecl (TyClD decl@(TyData {}))
258 = IfaceData { ifName = rdrNameOcc (tcdName decl),
260 ifCons = hsIfaceCons tvs decl,
261 ifRec = Recursive, -- Hi-boot decls are always loop-breakers
262 ifVrcs = [], ifGeneric = False }
263 -- I'm not sure that [] is right for ifVrcs, but
264 -- since we don't use them I'm not going to fiddle
266 tvs = hsIfaceTvs (tcdTyVars decl)
268 hsIfaceDecl decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
270 hsIfaceCons :: [IfaceTvBndr] -> TyClDecl RdrName -> IfaceConDecls
271 hsIfaceCons tvs decl@(TyData {tcdCtxt = L _ stupid_ctxt})
272 | not (null stupid_ctxt) -- Keep it simple: no data type contexts
273 -- Else we'll have to do "thinning"; sigh
274 = pprPgmError "Can't do data type contexts in hi-boot file:" (ppr decl)
276 hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = []})
277 = -- data T a, meaning "constructors unspecified",
278 IfAbstractTyCon -- not "no constructors"
280 hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = cons})
281 = IfDataTyCon Nothing (map (hsIfaceCon tvs . unLoc) cons)
283 hsIfaceCons tvs (TyData {tcdND = NewType, tcdCons = [con]})
284 = IfNewTyCon (hsIfaceCon tvs (unLoc con))
286 hsIfaceCons tvs decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
289 hsIfaceCon :: [IfaceTvBndr] -> ConDecl RdrName -> IfaceConDecl
290 hsIfaceCon tvs (ConDecl lname ex_tvs ex_ctxt details)
291 | null ex_tvs && null (unLoc ex_ctxt)
292 = IfVanillaCon { ifConOcc = get_occ lname,
293 ifConInfix = is_infix,
294 ifConArgTys = map hsIfaceLType args,
295 ifConStricts = map (hsStrictMark . getBangStrictness) args,
298 = IfGadtCon { ifConOcc = get_occ lname,
299 ifConTyVars = tvs ++ hsIfaceTvs ex_tvs,
300 ifConCtxt = hsIfaceCtxt (unLoc ex_ctxt),
301 ifConArgTys = map hsIfaceLType args,
302 ifConResTys = map (IfaceTyVar . fst) tvs,
303 ifConStricts = map (hsStrictMark . getBangStrictness) args }
304 | otherwise = pprPgmError "Fields illegal in existential" (ppr (unLoc lname))
306 (is_infix, args, flds) = case details of
307 PrefixCon args -> (False, args, [])
308 InfixCon a1 a2 -> (True, [a1,a2], [])
309 RecCon fs -> (False, map snd fs, map (get_occ . fst) fs)
310 get_occ lname = rdrNameOcc (unLoc lname)
312 hsIfaceCon _tvs (GadtDecl lname con_ty) -- Not yet
313 = pprPgmError "Can't use GADTs in hi-boot files (yet)" (ppr (unLoc lname))
315 hsStrictMark :: HsBang -> StrictnessMark
316 -- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
317 -- but in an hi-boot file it's interpreted as the Truth!
318 hsStrictMark HsNoBang = NotMarkedStrict
319 hsStrictMark HsStrict = MarkedStrict
320 hsStrictMark HsUnbox = MarkedUnboxed
322 hsIfaceName rdr_name -- Qualify unqualifed occurrences
323 -- with the module name
324 | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
325 | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
327 hsIfaceLType :: LHsType RdrName -> IfaceType
328 hsIfaceLType = hsIfaceType . unLoc
330 hsIfaceType :: HsType RdrName -> IfaceType
331 hsIfaceType (HsForAllTy exp tvs cxt ty)
332 = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
334 rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
335 tau = hsIfaceLType ty
337 Explicit -> map unLoc tvs
338 Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
340 hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
341 hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
342 hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
343 hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t]
344 hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
345 hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
346 hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
347 hsIfaceType (HsParTy t) = hsIfaceLType t
348 hsIfaceType (HsBangTy _ t) = hsIfaceLType t
349 hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
350 hsIfaceType (HsKindSig t _) = hsIfaceLType t
351 hsIfaceType ty = pprPanic "hsIfaceType" (ppr ty)
352 -- HsNumTy, HsSpliceTy
355 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
358 hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
359 hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
362 hsIfaceLPred :: LHsPred RdrName -> IfacePredType
363 hsIfaceLPred = hsIfacePred . unLoc
365 hsIfacePred :: HsPred RdrName -> IfacePredType
366 hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
367 hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
370 hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
371 hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
372 hs_tc_app (HsTyVar n) args
373 | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
374 | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
375 hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
378 hsIfaceTvs :: [LHsTyVarBndr RdrName] -> [IfaceTvBndr]
379 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
382 hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind)
383 hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
386 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
387 hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
391 %************************************************************************
393 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
395 %************************************************************************
397 Function definitions are restructured here. Each is assumed to be recursive
398 initially, and non recursive definitions are discovered by the dependency
403 -- | Groups together bindings for a single function
404 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
405 cvTopDecls decls = go (fromOL decls)
407 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
409 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
410 where (L l' b', ds') = getMonoBind (L l b) ds
411 go (d : ds) = d : go ds
413 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
415 = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
416 HsBindGroup mbs sigs Recursive -- just one big group for now
419 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
420 -> (Bag (LHsBind RdrName), [LSig RdrName])
421 -- Input decls contain just value bindings and signatures
422 cvBindsAndSigs fb = go (fromOL fb)
424 go [] = (emptyBag, [])
425 go (L l (SigD s) : ds) = (bs, L l s : ss)
426 where (bs,ss) = go ds
427 go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
428 where (b',ds') = getMonoBind (L l b) ds
431 -----------------------------------------------------------------------------
432 -- Group function bindings into equation groups
434 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
435 -> (LHsBind RdrName, [LHsDecl RdrName])
436 -- Suppose (b',ds') = getMonoBind b ds
437 -- ds is a *reversed* list of parsed bindings
438 -- b is a MonoBinds that has just been read off the front
440 -- Then b' is the result of grouping more equations from ds that
441 -- belong with b into a single MonoBinds, and ds' is the depleted
442 -- list of parsed bindings.
444 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
447 getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds
451 go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds)
452 | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
453 where loc = combineSrcSpans loc1 loc2
455 = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds)
456 -- reverse the final matches, to get it back in the right order
458 getMonoBind bind binds = (bind, binds)
460 has_args ((L _ (Match args _ _)) : _) = not (null args)
461 -- Don't group together FunBinds if they have
462 -- no arguments. This is necessary now that variable bindings
463 -- with no arguments are now treated as FunBinds rather
464 -- than pattern bindings (tests/rename/should_fail/rnfail002).
468 emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
469 hs_tyclds = [], hs_instds = [],
470 hs_fixds = [], hs_defds = [], hs_fords = [],
471 hs_depds = [] ,hs_ruleds = [] }
473 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
474 findSplice ds = addl emptyGroup ds
476 mkGroup :: [LHsDecl a] -> HsGroup a
477 mkGroup ds = addImpDecls emptyGroup ds
479 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
480 -- The decls are imported, and should not have a splice
481 addImpDecls group decls = case addl group decls of
482 (group', Nothing) -> group'
483 other -> panic "addImpDecls"
485 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
486 -- This stuff reverses the declarations (again) but it doesn't matter
489 addl gp [] = (gp, Nothing)
490 addl gp (L l d : ds) = add gp l d ds
493 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
494 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
496 add gp l (SpliceD e) ds = (gp, Just (e, ds))
498 -- Class declarations: pull out the fixity signatures to the top
499 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
501 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
502 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
504 addl (gp { hs_tyclds = L l d : ts }) ds
506 -- Signatures: fixity sigs go a different place than all others
507 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
508 = addl (gp {hs_fixds = L l f : ts}) ds
509 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
510 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
512 -- Value declarations: use add_bind
513 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
514 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
516 -- The rest are routine
517 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
518 = addl (gp { hs_instds = L l d : ts }) ds
519 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
520 = addl (gp { hs_defds = L l d : ts }) ds
521 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
522 = addl (gp { hs_fords = L l d : ts }) ds
523 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
524 = addl (gp { hs_depds = L l d : ts }) ds
525 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
526 = addl (gp { hs_ruleds = L l d : ts }) ds
528 add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r]
529 add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r]
532 %************************************************************************
534 \subsection[PrefixToHS-utils]{Utilities for conversion}
536 %************************************************************************
540 -----------------------------------------------------------------------------
543 -- When parsing data declarations, we sometimes inadvertently parse
544 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
545 -- This function splits up the type application, adds any pending
546 -- arguments, and converts the type constructor back into a data constructor.
548 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
549 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
553 split (L _ (HsAppTy t u)) ts = split t (u : ts)
554 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
555 return (data_con, PrefixCon ts)
556 split (L l _) _ = parseError l "parse error in data/newtype declaration"
558 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
559 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
560 mkRecCon (L loc con) fields
561 = do data_con <- tyConToDataCon loc con
562 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
564 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
565 tyConToDataCon loc tc
566 | isTcOcc (rdrNameOcc tc)
567 = return (L loc (setRdrNameSpace tc srcDataName))
569 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
571 ----------------------------------------------------------------------------
572 -- Various Syntactic Checks
574 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
575 checkInstType (L l t)
577 HsForAllTy exp tvs ctxt ty -> do
578 dict_ty <- checkDictTy ty
579 return (L l (HsForAllTy exp tvs ctxt dict_ty))
581 HsParTy ty -> checkInstType ty
583 ty -> do dict_ty <- checkDictTy (L l ty)
584 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
586 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
590 -- Check that the name space is correct!
591 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
592 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
593 chk (L l (HsTyVar tv))
594 | isRdrTyVar tv = return (L l (UserTyVar tv))
596 = parseError l "Type found where type variable expected"
598 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
599 -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
600 -- The header of a type or class decl should look like
601 -- (C a, D b) => T a b
605 checkTyClHdr (L l cxt) ty
606 = do (tc, tvs) <- gol ty []
608 return (L l cxt, tc, tvs)
610 gol (L l ty) acc = go l ty acc
612 go l (HsTyVar tc) acc
613 | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
615 go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
617 go l (HsParTy ty) acc = gol ty acc
618 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
619 go l other acc = parseError l "Malformed LHS to type of class declaration"
621 -- The predicates in a type or class decl must all
622 -- be HsClassPs. They need not all be type variables,
623 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
624 chk_pred (L l (HsClassP _ args)) = return ()
626 = parseError l "Malformed context in type or class declaration"
629 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
633 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
634 = do ctx <- mapM checkPred ts
637 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
640 check (HsTyVar t) -- Empty context shows up as a unit type ()
641 | t == getRdrName unitTyCon = return (L l [])
644 = do p <- checkPred (L l t)
648 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
649 -- Watch out.. in ...deriving( Show )... we use checkPred on
650 -- the list of partially applied predicates in the deriving,
651 -- so there can be zero args.
652 checkPred (L spn (HsPredTy (HsIParam n ty)))
653 = return (L spn (HsIParam n ty))
657 checkl (L l ty) args = check l ty args
659 check loc (HsTyVar t) args | not (isRdrTyVar t)
660 = return (L spn (HsClassP t args))
661 check loc (HsAppTy l r) args = checkl l (r:args)
662 check loc (HsParTy t) args = checkl t args
663 check loc _ _ = parseError loc "malformed class assertion"
665 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
666 checkDictTy (L spn ty) = check ty []
668 check (HsTyVar t) args | not (isRdrTyVar t)
669 = return (L spn (HsPredTy (HsClassP t args)))
670 check (HsAppTy l r) args = check (unLoc l) (r:args)
671 check (HsParTy t) args = check (unLoc t) args
672 check _ _ = parseError spn "Malformed context in instance header"
674 ---------------------------------------------------------------------------
675 -- Checking statements in a do-expression
676 -- We parse do { e1 ; e2 ; }
677 -- as [ExprStmt e1, ExprStmt e2]
678 -- checkDo (a) checks that the last thing is an ExprStmt
679 -- (b) transforms it to a ResultStmt
680 -- same comments apply for mdo as well
682 checkDo = checkDoMDo "a " "'do'"
683 checkMDo = checkDoMDo "an " "'mdo'"
685 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
686 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
687 checkDoMDo pre nm loc ss = do
690 check [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
691 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
692 " construct must be an expression")
697 -- -------------------------------------------------------------------------
698 -- Checking Patterns.
700 -- We parse patterns as expressions and check for valid patterns below,
701 -- converting the expression into a pattern at the same time.
703 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
704 checkPattern e = checkLPat e
706 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
707 checkPatterns es = mapM checkPattern es
709 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
710 checkLPat e@(L l _) = checkPat l e []
712 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
713 checkPat loc (L l (HsVar c)) args
714 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
715 checkPat loc (L _ (HsApp f x)) args = do
717 checkPat loc f (x:args)
718 checkPat loc (L _ e) [] = do
721 checkPat loc pat _some_args
724 checkAPat loc e = case e of
725 EWildPat -> return (WildPat placeHolderType)
726 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
728 | otherwise -> return (VarPat x)
729 HsLit l -> return (LitPat l)
731 -- Overloaded numeric patterns (e.g. f 0 x = x)
732 -- Negation is recorded separately, so that the literal is zero or +ve
733 -- NB. Negative *primitive* literals are already handled by
734 -- RdrHsSyn.mkHsNegApp
735 HsOverLit pos_lit -> return (NPatIn pos_lit Nothing)
736 NegApp (L _ (HsOverLit pos_lit)) _
737 -> return (NPatIn pos_lit (Just placeHolderName))
739 ELazyPat e -> checkLPat e >>= (return . LazyPat)
740 EAsPat n e -> checkLPat e >>= (return . AsPat n)
741 ExprWithTySig e t -> checkLPat e >>= \e ->
742 -- Pattern signatures are parsed as sigtypes,
743 -- but they aren't explicit forall points. Hence
744 -- we have to remove the implicit forall here.
746 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
749 return (SigPatIn e t')
752 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
753 (L _ (HsOverLit lit@(HsIntegral _ _)))
755 -> return (mkNPlusKPat (L nloc n) lit)
757 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
759 OpApp l op fix r -> checkLPat l >>= \l ->
760 checkLPat r >>= \r ->
762 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
763 -> return (ConPatIn (L cl c) (InfixCon l r))
766 HsPar e -> checkLPat e >>= (return . ParPat)
767 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
768 return (ListPat ps placeHolderType)
769 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
770 return (PArrPat ps placeHolderType)
772 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
773 return (TuplePat ps b)
775 RecordCon c fs -> mapM checkPatField fs >>= \fs ->
776 return (ConPatIn c (RecCon fs))
778 HsType ty -> return (TypePat ty)
781 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
782 checkPatField (n,e) = do
786 patFail loc = parseError loc "Parse error in pattern"
789 ---------------------------------------------------------------------------
790 -- Check Equation Syntax
794 -> Maybe (LHsType RdrName)
795 -> Located (GRHSs RdrName)
796 -> P (HsBind RdrName)
798 checkValDef lhs opt_sig (L rhs_span grhss)
799 | Just (f,inf,es) <- isFunLhs lhs []
800 = if isQual (unLoc f)
801 then parseError (getLoc f) ("Qualified name in function definition: " ++
802 showRdrName (unLoc f))
803 else do ps <- checkPatterns es
804 let match_span = combineSrcSpans (getLoc lhs) rhs_span
805 return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)]))
806 -- The span of the match covers the entire equation.
807 -- That isn't quite right, but it'll do for now.
809 lhs <- checkPattern lhs
810 return (PatBind lhs grhss placeHolderType)
816 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
817 checkValSig (L l other) ty
818 = parseError l "Type signature given for an expression"
820 -- A variable binding is parsed as a FunBind.
822 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
823 -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
824 isFunLhs (L loc e) = isFunLhs' loc e
826 isFunLhs' loc (HsVar f) es
827 | not (isRdrDataCon f) = Just (L loc f, False, es)
828 isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es)
829 isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es
830 isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
831 | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
833 case isFunLhs l es of
834 Just (op', True, j : k : es') ->
836 j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
838 isFunLhs' _ _ _ = Nothing
840 ---------------------------------------------------------------------------
841 -- Miscellaneous utilities
843 checkPrecP :: Located Int -> P Int
845 | 0 <= i && i <= maxPrecedence = return i
846 | otherwise = parseError l "Precedence out of range"
851 -> HsRecordBinds RdrName
852 -> P (HsExpr RdrName)
854 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
855 = return (RecordCon (L l c) fs)
856 mkRecConstrOrUpdate exp loc fs@(_:_)
857 = return (RecordUpd exp fs)
858 mkRecConstrOrUpdate _ loc []
859 = parseError loc "Empty record update"
861 -----------------------------------------------------------------------------
862 -- utilities for foreign declarations
864 -- supported calling conventions
866 data CallConv = CCall CCallConv -- ccall or stdcall
869 -- construct a foreign import declaration
873 -> (Located FastString, Located RdrName, LHsType RdrName)
874 -> P (HsDecl RdrName)
875 mkImport (CCall cconv) safety (entity, v, ty) = do
876 importSpec <- parseCImport entity cconv safety v
877 return (ForD (ForeignImport v ty importSpec False))
878 mkImport (DNCall ) _ (entity, v, ty) = do
879 spec <- parseDImport entity
880 return $ ForD (ForeignImport v ty (DNImport spec) False)
882 -- parse the entity string of a foreign import declaration for the `ccall' or
883 -- `stdcall' calling convention'
885 parseCImport :: Located FastString
890 parseCImport (L loc entity) cconv safety v
891 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
892 | entity == FSLIT ("dynamic") =
893 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
894 | entity == FSLIT ("wrapper") =
895 return $ CImport cconv safety nilFS nilFS CWrapper
896 | otherwise = parse0 (unpackFS entity)
898 -- using the static keyword?
899 parse0 (' ': rest) = parse0 rest
900 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
901 parse0 rest = parse1 rest
902 -- check for header file name
903 parse1 "" = parse4 "" nilFS False nilFS
904 parse1 (' ':rest) = parse1 rest
905 parse1 str@('&':_ ) = parse2 str nilFS
906 parse1 str@('[':_ ) = parse3 str nilFS False
908 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
909 | otherwise = parse4 str nilFS False nilFS
911 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
912 -- check for address operator (indicating a label import)
913 parse2 "" header = parse4 "" header False nilFS
914 parse2 (' ':rest) header = parse2 rest header
915 parse2 ('&':rest) header = parse3 rest header True
916 parse2 str@('[':_ ) header = parse3 str header False
917 parse2 str header = parse4 str header False nilFS
918 -- check for library object name
919 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
920 parse3 ('[':rest) header isLbl =
921 case break (== ']') rest of
922 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
923 _ -> parseError loc "Missing ']' in entity"
924 parse3 str header isLbl = parse4 str header isLbl nilFS
925 -- check for name of C function
926 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
927 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
928 parse4 str header isLbl lib
929 | all (== ' ') rest = build (mkFastString first) header isLbl lib
930 | otherwise = parseError loc "Malformed entity string"
932 (first, rest) = break (== ' ') str
934 build cid header False lib = return $
935 CImport cconv safety header lib (CFunction (StaticTarget cid))
936 build cid header True lib = return $
937 CImport cconv safety header lib (CLabel cid )
940 -- Unravel a dotnet spec string.
942 parseDImport :: Located FastString -> P DNCallSpec
943 parseDImport (L loc entity) = parse0 comps
945 comps = words (unpackFS entity)
949 | x == "static" = parse1 True xs
950 | otherwise = parse1 False (x:xs)
953 parse1 isStatic (x:xs)
954 | x == "method" = parse2 isStatic DNMethod xs
955 | x == "field" = parse2 isStatic DNField xs
956 | x == "ctor" = parse2 isStatic DNConstructor xs
957 parse1 isStatic xs = parse2 isStatic DNMethod xs
960 parse2 isStatic kind (('[':x):xs) =
963 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
964 parse2 isStatic kind xs = parse3 isStatic kind "" xs
966 parse3 isStatic kind assem [x] =
967 return (DNCallSpec isStatic kind assem x
968 -- these will be filled in once known.
969 (error "FFI-dotnet-args")
970 (error "FFI-dotnet-result"))
971 parse3 _ _ _ _ = d'oh
973 d'oh = parseError loc "Malformed entity string"
975 -- construct a foreign export declaration
978 -> (Located FastString, Located RdrName, LHsType RdrName)
979 -> P (HsDecl RdrName)
980 mkExport (CCall cconv) (L loc entity, v, ty) = return $
981 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
983 entity' | nullFastString entity = mkExtName (unLoc v)
985 mkExport DNCall (L loc entity, v, ty) =
986 parseError (getLoc v){-TODO: not quite right-}
987 "Foreign export is not yet supported for .NET"
989 -- Supplying the ext_name in a foreign decl is optional; if it
990 -- isn't there, the Haskell name is assumed. Note that no transformation
991 -- of the Haskell name is then performed, so if you foreign export (++),
992 -- it's external name will be "++". Too bad; it's important because we don't
993 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
994 -- (This is why we use occNameUserString.)
996 mkExtName :: RdrName -> CLabelString
997 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
1001 -----------------------------------------------------------------------------
1005 showRdrName :: RdrName -> String
1006 showRdrName r = showSDoc (ppr r)
1008 parseError :: SrcSpan -> String -> P a
1009 parseError span s = failSpanMsgP span s