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(..))
65 import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
66 occNameUserString, isValOcc )
67 import BasicTypes ( initialVersion, StrictnessMark(..) )
68 import Module ( ModuleName )
70 import CStrings ( CLabelString )
71 import CmdLineOpts ( opt_InPackage )
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 (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 _ _ 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 (context, tname, tyvars) data_cons maybe
168 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
169 tcdTyVars = tyvars, tcdCons = data_cons,
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 boring helper functions, have two purposes:
192 a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
193 an hi-boot file, and interfaces consist of the latter
194 b) Convert unqualifed names from the "current module" to qualified Orig
197 foo :: GHC.Base.Int -> GHC.Base.Int
199 This.foo :: GHC.Base.Int -> GHC.Base.Int
201 It assumes that everything is well kinded, of course.
204 mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
205 -- Make the ModIface for a hi-boot file
206 -- The decls are of very limited form
207 mkBootIface mod decls
208 = (emptyModIface opt_InPackage mod) {
210 mi_exports = [(mod, map mk_export decls')],
211 mi_decls = decls_w_vers,
212 mi_ver_fn = mkIfaceVerCache decls_w_vers }
214 decls' = map hsIfaceDecl decls
215 decls_w_vers = repeat initialVersion `zip` decls'
217 -- hi-boot declarations don't (currently)
218 -- expose constructors or class methods
219 mk_export decl | isValOcc occ = Avail occ
220 | otherwise = AvailTC occ [occ]
225 hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
226 -- Change to Iface syntax, and replace unqualified names with
227 -- qualified Orig names from this module. Reason: normal
228 -- iface files have everything fully qualified, so it's convenient
229 -- for hi-boot files to look the same
231 -- NB: no constructors or class ops to worry about
232 hsIfaceDecl (SigD (Sig name ty))
233 = IfaceId { ifName = rdrNameOcc (unLoc name),
234 ifType = hsIfaceLType ty,
237 hsIfaceDecl (TyClD decl@(TySynonym {}))
238 = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
239 ifTyVars = hsIfaceTvs (tcdTyVars decl),
240 ifSynRhs = hsIfaceLType (tcdSynRhs decl),
243 hsIfaceDecl (TyClD decl@(TyData {}))
244 = IfaceData { ifName = rdrNameOcc (tcdName decl),
245 ifTyVars = hsIfaceTvs (tcdTyVars decl),
246 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
247 ifCons = hsIfaceCons (tcdND decl) (tcdCons decl),
248 ifRec = NonRecursive,
249 ifVrcs = [], ifGeneric = False }
250 -- I'm not sure that [] is right for ifVrcs, but
251 -- since we don't use them I'm not going to fiddle
253 hsIfaceDecl (TyClD decl@(ClassDecl {}))
254 = IfaceClass { ifName = rdrNameOcc (tcdName decl),
255 ifTyVars = hsIfaceTvs (tcdTyVars decl),
256 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
257 ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
258 ifSigs = [], -- Is this right??
259 ifRec = NonRecursive, ifVrcs = [] }
261 hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
263 hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls
264 hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified",
265 = IfAbstractTyCon -- not "no constructors"
267 hsIfaceCons DataType cons -- data type
268 = IfDataTyCon (map (hsIfaceCon . unLoc) cons)
270 hsIfaceCons NewType [con] -- newtype
271 = IfNewTyCon (hsIfaceCon (unLoc con))
274 hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
275 hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
276 = IfaceConDecl (get_occ lname)
278 (hsIfaceCtxt (unLoc ex_ctxt))
279 (map (hsIfaceLType . getBangType . unLoc) args)
280 (map (hsStrictMark . getBangStrictness . unLoc) args)
283 (args, flds) = case details of
284 PrefixCon args -> (args, [])
285 InfixCon a1 a2 -> ([a1,a2], [])
286 RecCon fs -> (map snd fs, map (get_occ . fst) fs)
287 get_occ lname = rdrNameOcc (unLoc lname)
289 hsStrictMark :: HsBang -> StrictnessMark
290 -- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
291 -- but in an hi-boot file it's interpreted as the Truth!
292 hsStrictMark HsNoBang = NotMarkedStrict
293 hsStrictMark HsStrict = MarkedStrict
294 hsStrictMark HsUnbox = MarkedUnboxed
296 hsIfaceName rdr_name -- Qualify unqualifed occurrences
297 -- with the module name
298 | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
299 | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
301 hsIfaceLType :: LHsType RdrName -> IfaceType
302 hsIfaceLType = hsIfaceType . unLoc
304 hsIfaceType :: HsType RdrName -> IfaceType
305 hsIfaceType (HsForAllTy exp tvs cxt ty)
306 = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
308 rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
309 tau = hsIfaceLType ty
311 Explicit -> map unLoc tvs
312 Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
314 hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
315 hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
316 hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
317 hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t]
318 hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
319 hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
320 hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
321 hsIfaceType (HsParTy t) = hsIfaceLType t
322 hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
323 hsIfaceType (HsKindSig t _) = hsIfaceLType t
324 hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
325 hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy"
328 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
331 hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
332 hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
335 hsIfaceLPred :: LHsPred RdrName -> IfacePredType
336 hsIfaceLPred = hsIfacePred . unLoc
338 hsIfacePred :: HsPred RdrName -> IfacePredType
339 hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
340 hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
343 hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
344 hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
345 hs_tc_app (HsTyVar n) args
346 | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
347 | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
348 hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
351 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
354 hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind)
355 hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
358 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
359 hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
363 %************************************************************************
365 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
367 %************************************************************************
369 Function definitions are restructured here. Each is assumed to be recursive
370 initially, and non recursive definitions are discovered by the dependency
375 -- | Groups together bindings for a single function
376 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
377 cvTopDecls decls = go (fromOL decls)
379 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
381 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
382 where (L l' b', ds') = getMonoBind (L l b) ds
383 go (d : ds) = d : go ds
385 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
387 = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
388 HsBindGroup mbs sigs Recursive -- just one big group for now
391 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
392 -> (Bag (LHsBind RdrName), [LSig RdrName])
393 -- Input decls contain just value bindings and signatures
394 cvBindsAndSigs fb = go (fromOL fb)
396 go [] = (emptyBag, [])
397 go (L l (SigD s) : ds) = (bs, L l s : ss)
398 where (bs,ss) = go ds
399 go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
400 where (b',ds') = getMonoBind (L l b) ds
403 -----------------------------------------------------------------------------
404 -- Group function bindings into equation groups
406 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
407 -> (LHsBind RdrName, [LHsDecl RdrName])
408 -- Suppose (b',ds') = getMonoBind b ds
409 -- ds is a *reversed* list of parsed bindings
410 -- b is a MonoBinds that has just been read off the front
412 -- Then b' is the result of grouping more equations from ds that
413 -- belong with b into a single MonoBinds, and ds' is the depleted
414 -- list of parsed bindings.
416 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
418 getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
422 go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
423 | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
424 where loc = combineSrcSpans loc1 loc2
426 = (L loc (FunBind lf inf (reverse mtchs1)), binds)
427 -- reverse the final matches, to get it back in the right order
429 getMonoBind bind binds = (bind, binds)
431 has_args ((L _ (Match args _ _)) : _) = not (null args)
432 -- Don't group together FunBinds if they have
433 -- no arguments. This is necessary now that variable bindings
434 -- with no arguments are now treated as FunBinds rather
435 -- than pattern bindings (tests/rename/should_fail/rnfail002).
439 emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
440 hs_tyclds = [], hs_instds = [],
441 hs_fixds = [], hs_defds = [], hs_fords = [],
442 hs_depds = [] ,hs_ruleds = [] }
444 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
445 findSplice ds = addl emptyGroup ds
447 mkGroup :: [LHsDecl a] -> HsGroup a
448 mkGroup ds = addImpDecls emptyGroup ds
450 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
451 -- The decls are imported, and should not have a splice
452 addImpDecls group decls = case addl group decls of
453 (group', Nothing) -> group'
454 other -> panic "addImpDecls"
456 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
457 -- This stuff reverses the declarations (again) but it doesn't matter
460 addl gp [] = (gp, Nothing)
461 addl gp (L l d : ds) = add gp l d ds
464 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
465 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
467 add gp l (SpliceD e) ds = (gp, Just (e, ds))
469 -- Class declarations: pull out the fixity signatures to the top
470 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
472 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
473 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
475 addl (gp { hs_tyclds = L l d : ts }) ds
477 -- Signatures: fixity sigs go a different place than all others
478 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
479 = addl (gp {hs_fixds = L l f : ts}) ds
480 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
481 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
483 -- Value declarations: use add_bind
484 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
485 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
487 -- The rest are routine
488 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
489 = addl (gp { hs_instds = L l d : ts }) ds
490 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
491 = addl (gp { hs_defds = L l d : ts }) ds
492 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
493 = addl (gp { hs_fords = L l d : ts }) ds
494 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
495 = addl (gp { hs_depds = L l d : ts }) ds
496 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
497 = addl (gp { hs_ruleds = L l d : ts }) ds
499 add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r]
500 add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r]
503 %************************************************************************
505 \subsection[PrefixToHS-utils]{Utilities for conversion}
507 %************************************************************************
511 -----------------------------------------------------------------------------
514 -- When parsing data declarations, we sometimes inadvertently parse
515 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
516 -- This function splits up the type application, adds any pending
517 -- arguments, and converts the type constructor back into a data constructor.
519 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
520 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
524 split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
525 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
526 return (data_con, PrefixCon ts)
527 split (L l _) _ = parseError l "parse error in data/newtype declaration"
529 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
530 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
531 mkRecCon (L loc con) fields
532 = do data_con <- tyConToDataCon loc con
533 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
535 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
536 tyConToDataCon loc tc
537 | isTcOcc (rdrNameOcc tc)
538 = return (L loc (setRdrNameSpace tc srcDataName))
540 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
542 ----------------------------------------------------------------------------
543 -- Various Syntactic Checks
545 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
546 checkInstType (L l t)
548 HsForAllTy exp tvs ctxt ty -> do
549 dict_ty <- checkDictTy ty
550 return (L l (HsForAllTy exp tvs ctxt dict_ty))
552 HsParTy ty -> checkInstType ty
554 ty -> do dict_ty <- checkDictTy (L l ty)
555 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
557 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
561 -- Check that the name space is correct!
562 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
563 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
564 chk (L l (HsTyVar tv))
565 | isRdrTyVar tv = return (L l (UserTyVar tv))
567 = parseError l "Type found where type variable expected"
569 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
570 -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
571 -- The header of a type or class decl should look like
572 -- (C a, D b) => T a b
576 checkTyClHdr (L l cxt) ty
577 = do (tc, tvs) <- gol ty []
579 return (L l cxt, tc, tvs)
581 gol (L l ty) acc = go l ty acc
583 go l (HsTyVar tc) acc
584 | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
586 go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
588 go l (HsParTy ty) acc = gol ty acc
589 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
590 go l other acc = parseError l "Malformed LHS to type of class declaration"
592 -- The predicates in a type or class decl must all
593 -- be HsClassPs. They need not all be type variables,
594 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
595 chk_pred (L l (HsClassP _ args)) = return ()
597 = parseError l "Malformed context in type or class declaration"
600 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
604 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
605 = do ctx <- mapM checkPred ts
608 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
611 check (HsTyVar t) -- Empty context shows up as a unit type ()
612 | t == getRdrName unitTyCon = return (L l [])
615 = do p <- checkPred (L l t)
619 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
620 -- Watch out.. in ...deriving( Show )... we use checkPred on
621 -- the list of partially applied predicates in the deriving,
622 -- so there can be zero args.
623 checkPred (L spn (HsPredTy (HsIParam n ty)))
624 = return (L spn (HsIParam n ty))
628 checkl (L l ty) args = check l ty args
630 check loc (HsTyVar t) args | not (isRdrTyVar t)
631 = return (L spn (HsClassP t args))
632 check loc (HsAppTy l r) args = checkl l (r:args)
633 check loc (HsParTy t) args = checkl t args
634 check loc _ _ = parseError loc "malformed class assertion"
636 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
637 checkDictTy (L spn ty) = check ty []
639 check (HsTyVar t) args | not (isRdrTyVar t)
640 = return (L spn (HsPredTy (HsClassP t args)))
641 check (HsAppTy l r) args = check (unLoc l) (r:args)
642 check (HsParTy t) args = check (unLoc t) args
643 check _ _ = parseError spn "Malformed context in instance header"
645 ---------------------------------------------------------------------------
646 -- Checking statements in a do-expression
647 -- We parse do { e1 ; e2 ; }
648 -- as [ExprStmt e1, ExprStmt e2]
649 -- checkDo (a) checks that the last thing is an ExprStmt
650 -- (b) transforms it to a ResultStmt
651 -- same comments apply for mdo as well
653 checkDo = checkDoMDo "a " "'do'"
654 checkMDo = checkDoMDo "an " "'mdo'"
656 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
657 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
658 checkDoMDo pre nm loc ss = do
661 check [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
662 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
663 " construct must be an expression")
668 -- -------------------------------------------------------------------------
669 -- Checking Patterns.
671 -- We parse patterns as expressions and check for valid patterns below,
672 -- converting the expression into a pattern at the same time.
674 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
675 checkPattern e = checkLPat e
677 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
678 checkPatterns es = mapM checkPattern es
680 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
681 checkLPat e@(L l _) = checkPat l e []
683 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
684 checkPat loc (L l (HsVar c)) args
685 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
686 checkPat loc (L _ (HsApp f x)) args = do
688 checkPat loc f (x:args)
689 checkPat loc (L _ e) [] = do
692 checkPat loc pat _some_args
695 checkAPat loc e = case e of
696 EWildPat -> return (WildPat placeHolderType)
697 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
699 | otherwise -> return (VarPat x)
700 HsLit l -> return (LitPat l)
702 -- Overloaded numeric patterns (e.g. f 0 x = x)
703 -- Negation is recorded separately, so that the literal is zero or +ve
704 -- NB. Negative *primitive* literals are already handled by
705 -- RdrHsSyn.mkHsNegApp
706 HsOverLit pos_lit -> return (NPatIn pos_lit Nothing)
707 NegApp (L _ (HsOverLit pos_lit)) _
708 -> return (NPatIn pos_lit (Just placeHolderName))
710 ELazyPat e -> checkLPat e >>= (return . LazyPat)
711 EAsPat n e -> checkLPat e >>= (return . AsPat n)
712 ExprWithTySig e t -> checkLPat e >>= \e ->
713 -- Pattern signatures are parsed as sigtypes,
714 -- but they aren't explicit forall points. Hence
715 -- we have to remove the implicit forall here.
717 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
720 return (SigPatIn e t')
723 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
724 (L _ (HsOverLit lit@(HsIntegral _ _)))
726 -> return (mkNPlusKPat (L nloc n) lit)
728 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
730 OpApp l op fix r -> checkLPat l >>= \l ->
731 checkLPat r >>= \r ->
733 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
734 -> return (ConPatIn (L cl c) (InfixCon l r))
737 HsPar e -> checkLPat e >>= (return . ParPat)
738 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
739 return (ListPat ps placeHolderType)
740 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
741 return (PArrPat ps placeHolderType)
743 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
744 return (TuplePat ps b)
746 RecordCon c fs -> mapM checkPatField fs >>= \fs ->
747 return (ConPatIn c (RecCon fs))
749 HsType ty -> return (TypePat ty)
752 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
753 checkPatField (n,e) = do
757 patFail loc = parseError loc "Parse error in pattern"
760 ---------------------------------------------------------------------------
761 -- Check Equation Syntax
765 -> Maybe (LHsType RdrName)
767 -> P (HsBind RdrName)
769 checkValDef lhs opt_sig grhss
770 | Just (f,inf,es) <- isFunLhs lhs []
771 = if isQual (unLoc f)
772 then parseError (getLoc f) ("Qualified name in function definition: " ++
773 showRdrName (unLoc f))
774 else do ps <- checkPatterns es
775 return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
776 -- TODO: span is wrong
778 lhs <- checkPattern lhs
779 return (PatBind lhs grhss)
785 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
786 checkValSig (L l other) ty
787 = parseError l "Type signature given for an expression"
789 -- A variable binding is parsed as a FunBind.
791 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
792 -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
793 isFunLhs (L loc e) = isFunLhs' loc e
795 isFunLhs' loc (HsVar f) es
796 | not (isRdrDataCon f) = Just (L loc f, False, es)
797 isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es)
798 isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es
799 isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
800 | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
802 case isFunLhs l es of
803 Just (op', True, j : k : es') ->
805 j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
807 isFunLhs' _ _ _ = Nothing
809 ---------------------------------------------------------------------------
810 -- Miscellaneous utilities
812 checkPrecP :: Located Int -> P Int
814 | 0 <= i && i <= maxPrecedence = return i
815 | otherwise = parseError l "Precedence out of range"
820 -> HsRecordBinds RdrName
821 -> P (HsExpr RdrName)
823 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
824 = return (RecordCon (L l c) fs)
825 mkRecConstrOrUpdate exp loc fs@(_:_)
826 = return (RecordUpd exp fs)
827 mkRecConstrOrUpdate _ loc []
828 = parseError loc "Empty record update"
830 -----------------------------------------------------------------------------
831 -- utilities for foreign declarations
833 -- supported calling conventions
835 data CallConv = CCall CCallConv -- ccall or stdcall
838 -- construct a foreign import declaration
842 -> (Located FastString, Located RdrName, LHsType RdrName)
843 -> P (HsDecl RdrName)
844 mkImport (CCall cconv) safety (entity, v, ty) = do
845 importSpec <- parseCImport entity cconv safety v
846 return (ForD (ForeignImport v ty importSpec False))
847 mkImport (DNCall ) _ (entity, v, ty) = do
848 spec <- parseDImport entity
849 return $ ForD (ForeignImport v ty (DNImport spec) False)
851 -- parse the entity string of a foreign import declaration for the `ccall' or
852 -- `stdcall' calling convention'
854 parseCImport :: Located FastString
859 parseCImport (L loc entity) cconv safety v
860 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
861 | entity == FSLIT ("dynamic") =
862 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
863 | entity == FSLIT ("wrapper") =
864 return $ CImport cconv safety nilFS nilFS CWrapper
865 | otherwise = parse0 (unpackFS entity)
867 -- using the static keyword?
868 parse0 (' ': rest) = parse0 rest
869 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
870 parse0 rest = parse1 rest
871 -- check for header file name
872 parse1 "" = parse4 "" nilFS False nilFS
873 parse1 (' ':rest) = parse1 rest
874 parse1 str@('&':_ ) = parse2 str nilFS
875 parse1 str@('[':_ ) = parse3 str nilFS False
877 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
878 | otherwise = parse4 str nilFS False nilFS
880 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
881 -- check for address operator (indicating a label import)
882 parse2 "" header = parse4 "" header False nilFS
883 parse2 (' ':rest) header = parse2 rest header
884 parse2 ('&':rest) header = parse3 rest header True
885 parse2 str@('[':_ ) header = parse3 str header False
886 parse2 str header = parse4 str header False nilFS
887 -- check for library object name
888 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
889 parse3 ('[':rest) header isLbl =
890 case break (== ']') rest of
891 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
892 _ -> parseError loc "Missing ']' in entity"
893 parse3 str header isLbl = parse4 str header isLbl nilFS
894 -- check for name of C function
895 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
896 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
897 parse4 str header isLbl lib
898 | all (== ' ') rest = build (mkFastString first) header isLbl lib
899 | otherwise = parseError loc "Malformed entity string"
901 (first, rest) = break (== ' ') str
903 build cid header False lib = return $
904 CImport cconv safety header lib (CFunction (StaticTarget cid))
905 build cid header True lib = return $
906 CImport cconv safety header lib (CLabel cid )
909 -- Unravel a dotnet spec string.
911 parseDImport :: Located FastString -> P DNCallSpec
912 parseDImport (L loc entity) = parse0 comps
914 comps = words (unpackFS entity)
918 | x == "static" = parse1 True xs
919 | otherwise = parse1 False (x:xs)
922 parse1 isStatic (x:xs)
923 | x == "method" = parse2 isStatic DNMethod xs
924 | x == "field" = parse2 isStatic DNField xs
925 | x == "ctor" = parse2 isStatic DNConstructor xs
926 parse1 isStatic xs = parse2 isStatic DNMethod xs
929 parse2 isStatic kind (('[':x):xs) =
932 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
933 parse2 isStatic kind xs = parse3 isStatic kind "" xs
935 parse3 isStatic kind assem [x] =
936 return (DNCallSpec isStatic kind assem x
937 -- these will be filled in once known.
938 (error "FFI-dotnet-args")
939 (error "FFI-dotnet-result"))
940 parse3 _ _ _ _ = d'oh
942 d'oh = parseError loc "Malformed entity string"
944 -- construct a foreign export declaration
947 -> (Located FastString, Located RdrName, LHsType RdrName)
948 -> P (HsDecl RdrName)
949 mkExport (CCall cconv) (L loc entity, v, ty) = return $
950 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
952 entity' | nullFastString entity = mkExtName (unLoc v)
954 mkExport DNCall (L loc entity, v, ty) =
955 parseError (getLoc v){-TODO: not quite right-}
956 "Foreign export is not yet supported for .NET"
958 -- Supplying the ext_name in a foreign decl is optional; if it
959 -- isn't there, the Haskell name is assumed. Note that no transformation
960 -- of the Haskell name is then performed, so if you foreign export (++),
961 -- it's external name will be "++". Too bad; it's important because we don't
962 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
963 -- (This is why we use occNameUserString.)
965 mkExtName :: RdrName -> CLabelString
966 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
970 -----------------------------------------------------------------------------
974 showRdrName :: RdrName -> String
975 showRdrName r = showSDoc (ppr r)
977 parseError :: SrcSpan -> String -> P a
978 parseError span s = failSpanMsgP span s