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 )
54 import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) )
55 import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
56 isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
57 setRdrNameSpace, rdrNameModule )
58 import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
59 import Lexer ( P, failSpanMsgP )
60 import Kind ( liftedTypeKind )
61 import HscTypes ( GenAvailInfo(..) )
62 import TysWiredIn ( unitTyCon )
63 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
64 DNCallSpec(..), DNKind(..), CLabelString )
65 import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
66 occNameUserString, isValOcc )
67 import BasicTypes ( initialVersion, StrictnessMark(..) )
68 import Module ( ModuleName )
70 import CmdLineOpts ( opt_InPackage )
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 (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
111 extract_ty (HsListTy ty) acc = extract_lty ty acc
112 extract_ty (HsPArrTy ty) acc = extract_lty ty acc
113 extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys
114 extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
115 extract_ty (HsPredTy p) acc = extract_pred p acc
116 extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
117 extract_ty (HsParTy ty) acc = extract_lty ty acc
118 extract_ty (HsNumTy num) acc = acc
119 extract_ty (HsSpliceTy _) acc = acc -- Type splices mention no type variables
120 extract_ty (HsKindSig ty k) acc = extract_lty ty acc
121 extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
122 extract_ty (HsForAllTy exp tvs cx ty)
123 acc = (filter ((`notElem` locals) . unLoc) $
124 extract_lctxt cx (extract_lty ty [])) ++ acc
126 locals = hsLTyVarNames tvs
128 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
129 -- Get the type variables out of the type patterns in a bunch of
130 -- possibly-generic bindings in a class declaration
131 extractGenericPatTyVars binds
132 = nubBy eqLocated (foldrBag get [] binds)
134 get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms
137 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
138 get_m other acc = acc
142 %************************************************************************
144 \subsection{Construction functions for Rdr stuff}
146 %************************************************************************
148 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
149 by deriving them from the name of the class. We fill in the names for the
150 tycon and datacon corresponding to the class, by deriving them from the
151 name of the class itself. This saves recording the names in the interface
152 file (which would be equally good).
154 Similarly for mkConDecl, mkClassOpSig and default-method names.
156 *** See "THE NAMING STORY" in HsDecls ****
159 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
160 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
166 mkTyData new_or_data (context, tname, tyvars) data_cons maybe
167 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
168 tcdTyVars = tyvars, tcdCons = data_cons,
173 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
174 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
175 -- can't take an unboxed arg. But that is exactly what it will see when
176 -- we write "-3#". So we have to do the negation right now!
177 mkHsNegApp (L loc e) = f e
178 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
179 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
180 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
181 f expr = NegApp (L loc e) placeHolderName
184 %************************************************************************
188 %************************************************************************
190 mkBootIface, and its boring helper functions, have two purposes:
191 a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
192 an hi-boot file, and interfaces consist of the latter
193 b) Convert unqualifed names from the "current module" to qualified Orig
196 foo :: GHC.Base.Int -> GHC.Base.Int
198 This.foo :: GHC.Base.Int -> GHC.Base.Int
200 It assumes that everything is well kinded, of course.
203 mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
204 -- Make the ModIface for a hi-boot file
205 -- The decls are of very limited form
206 mkBootIface mod decls
207 = (emptyModIface opt_InPackage mod) {
209 mi_exports = [(mod, map mk_export decls')],
210 mi_decls = decls_w_vers,
211 mi_ver_fn = mkIfaceVerCache decls_w_vers }
213 decls' = map hsIfaceDecl decls
214 decls_w_vers = repeat initialVersion `zip` decls'
216 -- hi-boot declarations don't (currently)
217 -- expose constructors or class methods
218 mk_export decl | isValOcc occ = Avail occ
219 | otherwise = AvailTC occ [occ]
224 hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
225 -- Change to Iface syntax, and replace unqualified names with
226 -- qualified Orig names from this module. Reason: normal
227 -- iface files have everything fully qualified, so it's convenient
228 -- for hi-boot files to look the same
230 -- NB: no constructors or class ops to worry about
231 hsIfaceDecl (SigD (Sig name ty))
232 = IfaceId { ifName = rdrNameOcc (unLoc name),
233 ifType = hsIfaceLType ty,
236 hsIfaceDecl (TyClD decl@(TySynonym {}))
237 = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
238 ifTyVars = hsIfaceTvs (tcdTyVars decl),
239 ifSynRhs = hsIfaceLType (tcdSynRhs decl),
242 hsIfaceDecl (TyClD decl@(TyData {}))
243 = IfaceData { ifName = rdrNameOcc (tcdName decl),
244 ifTyVars = hsIfaceTvs (tcdTyVars decl),
245 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
246 ifCons = hsIfaceCons (tcdND decl) (tcdCons decl),
247 ifRec = NonRecursive,
248 ifVrcs = [], ifGeneric = False }
249 -- I'm not sure that [] is right for ifVrcs, but
250 -- since we don't use them I'm not going to fiddle
252 hsIfaceDecl (TyClD decl@(ClassDecl {}))
253 = IfaceClass { ifName = rdrNameOcc (tcdName decl),
254 ifTyVars = hsIfaceTvs (tcdTyVars decl),
255 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
256 ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
257 ifSigs = [], -- Is this right??
258 ifRec = NonRecursive, ifVrcs = [] }
260 hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
262 hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls
263 hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified",
264 = IfAbstractTyCon -- not "no constructors"
266 hsIfaceCons DataType cons -- data type
267 = IfDataTyCon (map (hsIfaceCon . unLoc) cons)
269 hsIfaceCons NewType [con] -- newtype
270 = IfNewTyCon (hsIfaceCon (unLoc con))
273 hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
274 hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
275 = IfaceConDecl (get_occ lname) is_infix
277 (hsIfaceCtxt (unLoc ex_ctxt))
278 (map (hsIfaceLType . getBangType . unLoc) args)
279 (map (hsStrictMark . getBangStrictness . unLoc) args)
282 (is_infix, args, flds) = case details of
283 PrefixCon args -> (False, args, [])
284 InfixCon a1 a2 -> (True, [a1,a2], [])
285 RecCon fs -> (False, map snd fs, map (get_occ . fst) fs)
286 get_occ lname = rdrNameOcc (unLoc lname)
288 hsStrictMark :: HsBang -> StrictnessMark
289 -- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
290 -- but in an hi-boot file it's interpreted as the Truth!
291 hsStrictMark HsNoBang = NotMarkedStrict
292 hsStrictMark HsStrict = MarkedStrict
293 hsStrictMark HsUnbox = MarkedUnboxed
295 hsIfaceName rdr_name -- Qualify unqualifed occurrences
296 -- with the module name
297 | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
298 | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
300 hsIfaceLType :: LHsType RdrName -> IfaceType
301 hsIfaceLType = hsIfaceType . unLoc
303 hsIfaceType :: HsType RdrName -> IfaceType
304 hsIfaceType (HsForAllTy exp tvs cxt ty)
305 = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
307 rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
308 tau = hsIfaceLType ty
310 Explicit -> map unLoc tvs
311 Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
313 hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
314 hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
315 hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
316 hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t]
317 hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
318 hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
319 hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
320 hsIfaceType (HsParTy t) = hsIfaceLType t
321 hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
322 hsIfaceType (HsKindSig t _) = hsIfaceLType t
323 hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
324 hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy"
327 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
330 hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
331 hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
334 hsIfaceLPred :: LHsPred RdrName -> IfacePredType
335 hsIfaceLPred = hsIfacePred . unLoc
337 hsIfacePred :: HsPred RdrName -> IfacePredType
338 hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
339 hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
342 hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
343 hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
344 hs_tc_app (HsTyVar n) args
345 | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
346 | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
347 hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
350 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
353 hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind)
354 hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
357 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
358 hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
362 %************************************************************************
364 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
366 %************************************************************************
368 Function definitions are restructured here. Each is assumed to be recursive
369 initially, and non recursive definitions are discovered by the dependency
374 -- | Groups together bindings for a single function
375 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
376 cvTopDecls decls = go (fromOL decls)
378 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
380 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
381 where (L l' b', ds') = getMonoBind (L l b) ds
382 go (d : ds) = d : go ds
384 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
386 = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
387 HsBindGroup mbs sigs Recursive -- just one big group for now
390 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
391 -> (Bag (LHsBind RdrName), [LSig RdrName])
392 -- Input decls contain just value bindings and signatures
393 cvBindsAndSigs fb = go (fromOL fb)
395 go [] = (emptyBag, [])
396 go (L l (SigD s) : ds) = (bs, L l s : ss)
397 where (bs,ss) = go ds
398 go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
399 where (b',ds') = getMonoBind (L l b) ds
402 -----------------------------------------------------------------------------
403 -- Group function bindings into equation groups
405 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
406 -> (LHsBind RdrName, [LHsDecl RdrName])
407 -- Suppose (b',ds') = getMonoBind b ds
408 -- ds is a *reversed* list of parsed bindings
409 -- b is a MonoBinds that has just been read off the front
411 -- Then b' is the result of grouping more equations from ds that
412 -- belong with b into a single MonoBinds, and ds' is the depleted
413 -- list of parsed bindings.
415 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
417 getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
421 go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
422 | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
423 where loc = combineSrcSpans loc1 loc2
425 = (L loc (FunBind lf inf (reverse mtchs1)), binds)
426 -- reverse the final matches, to get it back in the right order
428 getMonoBind bind binds = (bind, binds)
430 has_args ((L _ (Match args _ _)) : _) = not (null args)
431 -- Don't group together FunBinds if they have
432 -- no arguments. This is necessary now that variable bindings
433 -- with no arguments are now treated as FunBinds rather
434 -- than pattern bindings (tests/rename/should_fail/rnfail002).
438 emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
439 hs_tyclds = [], hs_instds = [],
440 hs_fixds = [], hs_defds = [], hs_fords = [],
441 hs_depds = [] ,hs_ruleds = [] }
443 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
444 findSplice ds = addl emptyGroup ds
446 mkGroup :: [LHsDecl a] -> HsGroup a
447 mkGroup ds = addImpDecls emptyGroup ds
449 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
450 -- The decls are imported, and should not have a splice
451 addImpDecls group decls = case addl group decls of
452 (group', Nothing) -> group'
453 other -> panic "addImpDecls"
455 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
456 -- This stuff reverses the declarations (again) but it doesn't matter
459 addl gp [] = (gp, Nothing)
460 addl gp (L l d : ds) = add gp l d ds
463 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
464 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
466 add gp l (SpliceD e) ds = (gp, Just (e, ds))
468 -- Class declarations: pull out the fixity signatures to the top
469 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
471 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
472 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
474 addl (gp { hs_tyclds = L l d : ts }) ds
476 -- Signatures: fixity sigs go a different place than all others
477 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
478 = addl (gp {hs_fixds = L l f : ts}) ds
479 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
480 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
482 -- Value declarations: use add_bind
483 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
484 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
486 -- The rest are routine
487 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
488 = addl (gp { hs_instds = L l d : ts }) ds
489 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
490 = addl (gp { hs_defds = L l d : ts }) ds
491 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
492 = addl (gp { hs_fords = L l d : ts }) ds
493 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
494 = addl (gp { hs_depds = L l d : ts }) ds
495 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
496 = addl (gp { hs_ruleds = L l d : ts }) ds
498 add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r]
499 add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r]
502 %************************************************************************
504 \subsection[PrefixToHS-utils]{Utilities for conversion}
506 %************************************************************************
510 -----------------------------------------------------------------------------
513 -- When parsing data declarations, we sometimes inadvertently parse
514 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
515 -- This function splits up the type application, adds any pending
516 -- arguments, and converts the type constructor back into a data constructor.
518 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
519 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
523 split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
524 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
525 return (data_con, PrefixCon ts)
526 split (L l _) _ = parseError l "parse error in data/newtype declaration"
528 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
529 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
530 mkRecCon (L loc con) fields
531 = do data_con <- tyConToDataCon loc con
532 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
534 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
535 tyConToDataCon loc tc
536 | isTcOcc (rdrNameOcc tc)
537 = return (L loc (setRdrNameSpace tc srcDataName))
539 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
541 ----------------------------------------------------------------------------
542 -- Various Syntactic Checks
544 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
545 checkInstType (L l t)
547 HsForAllTy exp tvs ctxt ty -> do
548 dict_ty <- checkDictTy ty
549 return (L l (HsForAllTy exp tvs ctxt dict_ty))
551 HsParTy ty -> checkInstType ty
553 ty -> do dict_ty <- checkDictTy (L l ty)
554 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
556 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
560 -- Check that the name space is correct!
561 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
562 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
563 chk (L l (HsTyVar tv))
564 | isRdrTyVar tv = return (L l (UserTyVar tv))
566 = parseError l "Type found where type variable expected"
568 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
569 -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
570 -- The header of a type or class decl should look like
571 -- (C a, D b) => T a b
575 checkTyClHdr (L l cxt) ty
576 = do (tc, tvs) <- gol ty []
578 return (L l cxt, tc, tvs)
580 gol (L l ty) acc = go l ty acc
582 go l (HsTyVar tc) acc
583 | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
585 go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
587 go l (HsParTy ty) acc = gol ty acc
588 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
589 go l other acc = parseError l "Malformed LHS to type of class declaration"
591 -- The predicates in a type or class decl must all
592 -- be HsClassPs. They need not all be type variables,
593 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
594 chk_pred (L l (HsClassP _ args)) = return ()
596 = parseError l "Malformed context in type or class declaration"
599 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
603 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
604 = do ctx <- mapM checkPred ts
607 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
610 check (HsTyVar t) -- Empty context shows up as a unit type ()
611 | t == getRdrName unitTyCon = return (L l [])
614 = do p <- checkPred (L l t)
618 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
619 -- Watch out.. in ...deriving( Show )... we use checkPred on
620 -- the list of partially applied predicates in the deriving,
621 -- so there can be zero args.
622 checkPred (L spn (HsPredTy (HsIParam n ty)))
623 = return (L spn (HsIParam n ty))
627 checkl (L l ty) args = check l ty args
629 check loc (HsTyVar t) args | not (isRdrTyVar t)
630 = return (L spn (HsClassP t args))
631 check loc (HsAppTy l r) args = checkl l (r:args)
632 check loc (HsParTy t) args = checkl t args
633 check loc _ _ = parseError loc "malformed class assertion"
635 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
636 checkDictTy (L spn ty) = check ty []
638 check (HsTyVar t) args | not (isRdrTyVar t)
639 = return (L spn (HsPredTy (HsClassP t args)))
640 check (HsAppTy l r) args = check (unLoc l) (r:args)
641 check (HsParTy t) args = check (unLoc t) args
642 check _ _ = parseError spn "Malformed context in instance header"
644 ---------------------------------------------------------------------------
645 -- Checking statements in a do-expression
646 -- We parse do { e1 ; e2 ; }
647 -- as [ExprStmt e1, ExprStmt e2]
648 -- checkDo (a) checks that the last thing is an ExprStmt
649 -- (b) transforms it to a ResultStmt
650 -- same comments apply for mdo as well
652 checkDo = checkDoMDo "a " "'do'"
653 checkMDo = checkDoMDo "an " "'mdo'"
655 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
656 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
657 checkDoMDo pre nm loc ss = do
660 check [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
661 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
662 " construct must be an expression")
667 -- -------------------------------------------------------------------------
668 -- Checking Patterns.
670 -- We parse patterns as expressions and check for valid patterns below,
671 -- converting the expression into a pattern at the same time.
673 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
674 checkPattern e = checkLPat e
676 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
677 checkPatterns es = mapM checkPattern es
679 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
680 checkLPat e@(L l _) = checkPat l e []
682 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
683 checkPat loc (L l (HsVar c)) args
684 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
685 checkPat loc (L _ (HsApp f x)) args = do
687 checkPat loc f (x:args)
688 checkPat loc (L _ e) [] = do
691 checkPat loc pat _some_args
694 checkAPat loc e = case e of
695 EWildPat -> return (WildPat placeHolderType)
696 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
698 | otherwise -> return (VarPat x)
699 HsLit l -> return (LitPat l)
701 -- Overloaded numeric patterns (e.g. f 0 x = x)
702 -- Negation is recorded separately, so that the literal is zero or +ve
703 -- NB. Negative *primitive* literals are already handled by
704 -- RdrHsSyn.mkHsNegApp
705 HsOverLit pos_lit -> return (NPatIn pos_lit Nothing)
706 NegApp (L _ (HsOverLit pos_lit)) _
707 -> return (NPatIn pos_lit (Just placeHolderName))
709 ELazyPat e -> checkLPat e >>= (return . LazyPat)
710 EAsPat n e -> checkLPat e >>= (return . AsPat n)
711 ExprWithTySig e t -> checkLPat e >>= \e ->
712 -- Pattern signatures are parsed as sigtypes,
713 -- but they aren't explicit forall points. Hence
714 -- we have to remove the implicit forall here.
716 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
719 return (SigPatIn e t')
722 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
723 (L _ (HsOverLit lit@(HsIntegral _ _)))
725 -> return (mkNPlusKPat (L nloc n) lit)
727 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
729 OpApp l op fix r -> checkLPat l >>= \l ->
730 checkLPat r >>= \r ->
732 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
733 -> return (ConPatIn (L cl c) (InfixCon l r))
736 HsPar e -> checkLPat e >>= (return . ParPat)
737 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
738 return (ListPat ps placeHolderType)
739 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
740 return (PArrPat ps placeHolderType)
742 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
743 return (TuplePat ps b)
745 RecordCon c fs -> mapM checkPatField fs >>= \fs ->
746 return (ConPatIn c (RecCon fs))
748 HsType ty -> return (TypePat ty)
751 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
752 checkPatField (n,e) = do
756 patFail loc = parseError loc "Parse error in pattern"
759 ---------------------------------------------------------------------------
760 -- Check Equation Syntax
764 -> Maybe (LHsType RdrName)
765 -> Located (GRHSs RdrName)
766 -> P (HsBind RdrName)
768 checkValDef lhs opt_sig (L rhs_span grhss)
769 | Just (f,inf,es) <- isFunLhs lhs []
770 = if isQual (unLoc f)
771 then parseError (getLoc f) ("Qualified name in function definition: " ++
772 showRdrName (unLoc f))
773 else do ps <- checkPatterns es
774 return (FunBind f inf [L rhs_span (Match ps opt_sig grhss)])
776 lhs <- checkPattern lhs
777 return (PatBind lhs grhss)
783 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
784 checkValSig (L l other) ty
785 = parseError l "Type signature given for an expression"
787 -- A variable binding is parsed as a FunBind.
789 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
790 -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
791 isFunLhs (L loc e) = isFunLhs' loc e
793 isFunLhs' loc (HsVar f) es
794 | not (isRdrDataCon f) = Just (L loc f, False, es)
795 isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es)
796 isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es
797 isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
798 | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
800 case isFunLhs l es of
801 Just (op', True, j : k : es') ->
803 j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
805 isFunLhs' _ _ _ = Nothing
807 ---------------------------------------------------------------------------
808 -- Miscellaneous utilities
810 checkPrecP :: Located Int -> P Int
812 | 0 <= i && i <= maxPrecedence = return i
813 | otherwise = parseError l "Precedence out of range"
818 -> HsRecordBinds RdrName
819 -> P (HsExpr RdrName)
821 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
822 = return (RecordCon (L l c) fs)
823 mkRecConstrOrUpdate exp loc fs@(_:_)
824 = return (RecordUpd exp fs)
825 mkRecConstrOrUpdate _ loc []
826 = parseError loc "Empty record update"
828 -----------------------------------------------------------------------------
829 -- utilities for foreign declarations
831 -- supported calling conventions
833 data CallConv = CCall CCallConv -- ccall or stdcall
836 -- construct a foreign import declaration
840 -> (Located FastString, Located RdrName, LHsType RdrName)
841 -> P (HsDecl RdrName)
842 mkImport (CCall cconv) safety (entity, v, ty) = do
843 importSpec <- parseCImport entity cconv safety v
844 return (ForD (ForeignImport v ty importSpec False))
845 mkImport (DNCall ) _ (entity, v, ty) = do
846 spec <- parseDImport entity
847 return $ ForD (ForeignImport v ty (DNImport spec) False)
849 -- parse the entity string of a foreign import declaration for the `ccall' or
850 -- `stdcall' calling convention'
852 parseCImport :: Located FastString
857 parseCImport (L loc entity) cconv safety v
858 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
859 | entity == FSLIT ("dynamic") =
860 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
861 | entity == FSLIT ("wrapper") =
862 return $ CImport cconv safety nilFS nilFS CWrapper
863 | otherwise = parse0 (unpackFS entity)
865 -- using the static keyword?
866 parse0 (' ': rest) = parse0 rest
867 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
868 parse0 rest = parse1 rest
869 -- check for header file name
870 parse1 "" = parse4 "" nilFS False nilFS
871 parse1 (' ':rest) = parse1 rest
872 parse1 str@('&':_ ) = parse2 str nilFS
873 parse1 str@('[':_ ) = parse3 str nilFS False
875 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
876 | otherwise = parse4 str nilFS False nilFS
878 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
879 -- check for address operator (indicating a label import)
880 parse2 "" header = parse4 "" header False nilFS
881 parse2 (' ':rest) header = parse2 rest header
882 parse2 ('&':rest) header = parse3 rest header True
883 parse2 str@('[':_ ) header = parse3 str header False
884 parse2 str header = parse4 str header False nilFS
885 -- check for library object name
886 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
887 parse3 ('[':rest) header isLbl =
888 case break (== ']') rest of
889 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
890 _ -> parseError loc "Missing ']' in entity"
891 parse3 str header isLbl = parse4 str header isLbl nilFS
892 -- check for name of C function
893 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
894 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
895 parse4 str header isLbl lib
896 | all (== ' ') rest = build (mkFastString first) header isLbl lib
897 | otherwise = parseError loc "Malformed entity string"
899 (first, rest) = break (== ' ') str
901 build cid header False lib = return $
902 CImport cconv safety header lib (CFunction (StaticTarget cid))
903 build cid header True lib = return $
904 CImport cconv safety header lib (CLabel cid )
907 -- Unravel a dotnet spec string.
909 parseDImport :: Located FastString -> P DNCallSpec
910 parseDImport (L loc entity) = parse0 comps
912 comps = words (unpackFS entity)
916 | x == "static" = parse1 True xs
917 | otherwise = parse1 False (x:xs)
920 parse1 isStatic (x:xs)
921 | x == "method" = parse2 isStatic DNMethod xs
922 | x == "field" = parse2 isStatic DNField xs
923 | x == "ctor" = parse2 isStatic DNConstructor xs
924 parse1 isStatic xs = parse2 isStatic DNMethod xs
927 parse2 isStatic kind (('[':x):xs) =
930 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
931 parse2 isStatic kind xs = parse3 isStatic kind "" xs
933 parse3 isStatic kind assem [x] =
934 return (DNCallSpec isStatic kind assem x
935 -- these will be filled in once known.
936 (error "FFI-dotnet-args")
937 (error "FFI-dotnet-result"))
938 parse3 _ _ _ _ = d'oh
940 d'oh = parseError loc "Malformed entity string"
942 -- construct a foreign export declaration
945 -> (Located FastString, Located RdrName, LHsType RdrName)
946 -> P (HsDecl RdrName)
947 mkExport (CCall cconv) (L loc entity, v, ty) = return $
948 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
950 entity' | nullFastString entity = mkExtName (unLoc v)
952 mkExport DNCall (L loc entity, v, ty) =
953 parseError (getLoc v){-TODO: not quite right-}
954 "Foreign export is not yet supported for .NET"
956 -- Supplying the ext_name in a foreign decl is optional; if it
957 -- isn't there, the Haskell name is assumed. Note that no transformation
958 -- of the Haskell name is then performed, so if you foreign export (++),
959 -- it's external name will be "++". Too bad; it's important because we don't
960 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
961 -- (This is why we use occNameUserString.)
963 mkExtName :: RdrName -> CLabelString
964 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
968 -----------------------------------------------------------------------------
972 showRdrName :: RdrName -> String
973 showRdrName r = showSDoc (ppr r)
975 parseError :: SrcSpan -> String -> P a
976 parseError span s = failSpanMsgP span s