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(..) )
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 HscTypes ( GenAvailInfo(..) )
61 import TysWiredIn ( unitTyCon )
62 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
63 DNCallSpec(..), DNKind(..))
64 import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
65 occNameUserString, isValOcc )
66 import BasicTypes ( initialVersion )
67 import TyCon ( DataConDetails(..) )
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 (unLoc 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 (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 { ifND = tcdND decl,
244 ifName = rdrNameOcc (tcdName decl),
245 ifTyVars = hsIfaceTvs (tcdTyVars decl),
246 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
247 ifCons = Unknown, 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 hsIfaceName rdr_name -- Qualify unqualifed occurrences
263 -- with the module name
264 | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
265 | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
267 hsIfaceLType :: LHsType RdrName -> IfaceType
268 hsIfaceLType = hsIfaceType . unLoc
270 hsIfaceType :: HsType RdrName -> IfaceType
271 hsIfaceType (HsForAllTy exp tvs cxt ty)
272 = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
274 rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
275 tau = hsIfaceLType ty
277 Explicit -> map unLoc tvs
278 Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
280 hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
281 hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
282 hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
283 hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t]
284 hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
285 hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
286 hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
287 hsIfaceType (HsParTy t) = hsIfaceLType t
288 hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
289 hsIfaceType (HsPredTy p) = IfacePredTy (hsIfaceLPred p)
290 hsIfaceType (HsKindSig t _) = hsIfaceLType t
293 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
296 hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
297 hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
300 hsIfaceLPred :: LHsPred RdrName -> IfacePredType
301 hsIfaceLPred = hsIfacePred . unLoc
303 hsIfacePred :: HsPred RdrName -> IfacePredType
304 hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
305 hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
308 hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
309 hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
310 hs_tc_app (HsTyVar n) args
311 | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
312 | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
313 hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
316 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
319 hsIfaceTv (UserTyVar n) = (rdrNameOcc n, IfaceLiftedTypeKind)
320 hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k)
323 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
324 hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
328 %************************************************************************
330 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
332 %************************************************************************
334 Function definitions are restructured here. Each is assumed to be recursive
335 initially, and non recursive definitions are discovered by the dependency
340 -- | Groups together bindings for a single function
341 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
342 cvTopDecls decls = go (fromOL decls)
344 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
346 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
347 where (L l' b', ds') = getMonoBind (L l b) ds
348 go (d : ds) = d : go ds
350 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
352 = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
353 HsBindGroup mbs sigs Recursive -- just one big group for now
356 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
357 -> (Bag (LHsBind RdrName), [LSig RdrName])
358 -- Input decls contain just value bindings and signatures
359 cvBindsAndSigs fb = go (fromOL fb)
361 go [] = (emptyBag, [])
362 go (L l (SigD s) : ds) = (bs, L l s : ss)
363 where (bs,ss) = go ds
364 go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
365 where (b',ds') = getMonoBind (L l b) ds
368 -----------------------------------------------------------------------------
369 -- Group function bindings into equation groups
371 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
372 -> (LHsBind RdrName, [LHsDecl RdrName])
373 -- Suppose (b',ds') = getMonoBind b ds
374 -- ds is a *reversed* list of parsed bindings
375 -- b is a MonoBinds that has just been read off the front
377 -- Then b' is the result of grouping more equations from ds that
378 -- belong with b into a single MonoBinds, and ds' is the depleted
379 -- list of parsed bindings.
381 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
383 getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
387 go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
388 | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
389 where loc = combineSrcSpans loc1 loc2
391 = (L loc (FunBind lf inf (reverse mtchs1)), binds)
392 -- reverse the final matches, to get it back in the right order
394 getMonoBind bind binds = (bind, binds)
396 has_args ((L _ (Match args _ _)) : _) = not (null args)
397 -- Don't group together FunBinds if they have
398 -- no arguments. This is necessary now that variable bindings
399 -- with no arguments are now treated as FunBinds rather
400 -- than pattern bindings (tests/rename/should_fail/rnfail002).
404 emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
405 hs_tyclds = [], hs_instds = [],
406 hs_fixds = [], hs_defds = [], hs_fords = [],
407 hs_depds = [] ,hs_ruleds = [] }
409 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
410 findSplice ds = addl emptyGroup ds
412 mkGroup :: [LHsDecl a] -> HsGroup a
413 mkGroup ds = addImpDecls emptyGroup ds
415 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
416 -- The decls are imported, and should not have a splice
417 addImpDecls group decls = case addl group decls of
418 (group', Nothing) -> group'
419 other -> panic "addImpDecls"
421 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
422 -- This stuff reverses the declarations (again) but it doesn't matter
425 addl gp [] = (gp, Nothing)
426 addl gp (L l d : ds) = add gp l d ds
429 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
430 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
432 add gp l (SpliceD e) ds = (gp, Just (e, ds))
434 -- Class declarations: pull out the fixity signatures to the top
435 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
437 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
438 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
440 addl (gp { hs_tyclds = L l d : ts }) ds
442 -- Signatures: fixity sigs go a different place than all others
443 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
444 = addl (gp {hs_fixds = L l f : ts}) ds
445 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
446 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
448 -- Value declarations: use add_bind
449 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
450 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
452 -- The rest are routine
453 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
454 = addl (gp { hs_instds = L l d : ts }) ds
455 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
456 = addl (gp { hs_defds = L l d : ts }) ds
457 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
458 = addl (gp { hs_fords = L l d : ts }) ds
459 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
460 = addl (gp { hs_depds = L l d : ts }) ds
461 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
462 = addl (gp { hs_ruleds = L l d : ts }) ds
464 add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r]
465 add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r]
468 %************************************************************************
470 \subsection[PrefixToHS-utils]{Utilities for conversion}
472 %************************************************************************
476 -----------------------------------------------------------------------------
479 -- When parsing data declarations, we sometimes inadvertently parse
480 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
481 -- This function splits up the type application, adds any pending
482 -- arguments, and converts the type constructor back into a data constructor.
484 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
485 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
489 split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
490 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
491 return (data_con, PrefixCon ts)
492 split (L l _) _ = parseError l "parse error in data/newtype declaration"
494 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
495 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
496 mkRecCon (L loc con) fields
497 = do data_con <- tyConToDataCon loc con
498 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
500 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
501 tyConToDataCon loc tc
502 | isTcOcc (rdrNameOcc tc)
503 = return (L loc (setRdrNameSpace tc srcDataName))
505 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
507 ----------------------------------------------------------------------------
508 -- Various Syntactic Checks
510 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
511 checkInstType (L l t)
513 HsForAllTy exp tvs ctxt ty -> do
514 dict_ty <- checkDictTy ty
515 return (L l (HsForAllTy exp tvs ctxt dict_ty))
517 HsParTy ty -> checkInstType ty
519 ty -> do dict_ty <- checkDictTy (L l ty)
520 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
522 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
526 -- Check that the name space is correct!
527 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
528 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
529 chk (L l (HsTyVar tv))
530 | isRdrTyVar tv = return (L l (UserTyVar tv))
532 = parseError l "Type found where type variable expected"
534 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
535 -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
536 -- The header of a type or class decl should look like
537 -- (C a, D b) => T a b
541 checkTyClHdr (L l cxt) ty
542 = do (tc, tvs) <- gol ty []
544 return (L l cxt, tc, tvs)
546 gol (L l ty) acc = go l ty acc
548 go l (HsTyVar tc) acc
549 | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
551 go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
553 go l (HsParTy ty) acc = gol ty acc
554 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
555 go l other acc = parseError l "Malformed LHS to type of class declaration"
557 -- The predicates in a type or class decl must all
558 -- be HsClassPs. They need not all be type variables,
559 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
560 chk_pred (L l (HsClassP _ args)) = return ()
562 = parseError l "Malformed context in type or class declaration"
565 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
569 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
570 = do ctx <- mapM checkPred ts
573 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
576 check (HsTyVar t) -- Empty context shows up as a unit type ()
577 | t == getRdrName unitTyCon = return (L l [])
580 = do p <- checkPred (L l t)
584 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
585 -- Watch out.. in ...deriving( Show )... we use checkPred on
586 -- the list of partially applied predicates in the deriving,
587 -- so there can be zero args.
588 checkPred (L spn (HsPredTy (L _ (HsIParam n ty))) )
589 = return (L spn (HsIParam n ty))
593 checkl (L l ty) args = check l ty args
595 check loc (HsTyVar t) args | not (isRdrTyVar t)
596 = return (L spn (HsClassP t args))
597 check loc (HsAppTy l r) args = checkl l (r:args)
598 check loc (HsParTy t) args = checkl t args
599 check loc _ _ = parseError loc "malformed class assertion"
601 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
602 checkDictTy (L spn ty) = check ty []
604 check (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
605 = return (L spn (HsPredTy (L spn (HsClassP t args))))
606 check (HsAppTy l r) args = check (unLoc l) (r:args)
607 check (HsParTy t) args = check (unLoc t) args
608 check _ _ = parseError spn "Malformed context in instance header"
610 ---------------------------------------------------------------------------
611 -- Checking statements in a do-expression
612 -- We parse do { e1 ; e2 ; }
613 -- as [ExprStmt e1, ExprStmt e2]
614 -- checkDo (a) checks that the last thing is an ExprStmt
615 -- (b) transforms it to a ResultStmt
616 -- same comments apply for mdo as well
618 checkDo = checkDoMDo "a " "'do'"
619 checkMDo = checkDoMDo "an " "'mdo'"
621 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
622 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
623 checkDoMDo pre nm loc ss = do
626 check [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
627 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
628 " construct must be an expression")
633 -- -------------------------------------------------------------------------
634 -- Checking Patterns.
636 -- We parse patterns as expressions and check for valid patterns below,
637 -- converting the expression into a pattern at the same time.
639 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
640 checkPattern e = checkLPat e
642 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
643 checkPatterns es = mapM checkPattern es
645 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
646 checkLPat e@(L l _) = checkPat l e []
648 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
649 checkPat loc (L l (HsVar c)) args
650 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
651 checkPat loc (L _ (HsApp f x)) args = do
653 checkPat loc f (x:args)
654 checkPat loc (L _ e) [] = do
657 checkPat loc pat _some_args
660 checkAPat loc e = case e of
661 EWildPat -> return (WildPat placeHolderType)
662 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
664 | otherwise -> return (VarPat x)
665 HsLit l -> return (LitPat l)
667 -- Overloaded numeric patterns (e.g. f 0 x = x)
668 -- Negation is recorded separately, so that the literal is zero or +ve
669 -- NB. Negative *primitive* literals are already handled by
670 -- RdrHsSyn.mkHsNegApp
671 HsOverLit pos_lit -> return (NPatIn pos_lit Nothing)
672 NegApp (L _ (HsOverLit pos_lit)) _
673 -> return (NPatIn pos_lit (Just placeHolderName))
675 ELazyPat e -> checkLPat e >>= (return . LazyPat)
676 EAsPat n e -> checkLPat e >>= (return . AsPat n)
677 ExprWithTySig e t -> checkLPat e >>= \e ->
678 -- Pattern signatures are parsed as sigtypes,
679 -- but they aren't explicit forall points. Hence
680 -- we have to remove the implicit forall here.
682 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
685 return (SigPatIn e t')
688 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
689 (L _ (HsOverLit lit@(HsIntegral _ _)))
691 -> return (mkNPlusKPat (L nloc n) lit)
693 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
695 OpApp l op fix r -> checkLPat l >>= \l ->
696 checkLPat r >>= \r ->
698 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
699 -> return (ConPatIn (L cl c) (InfixCon l r))
702 HsPar e -> checkLPat e >>= (return . ParPat)
703 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
704 return (ListPat ps placeHolderType)
705 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
706 return (PArrPat ps placeHolderType)
708 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
709 return (TuplePat ps b)
711 RecordCon c fs -> mapM checkPatField fs >>= \fs ->
712 return (ConPatIn c (RecCon fs))
714 HsType ty -> return (TypePat ty)
717 checkAPat loc _ = patFail loc
719 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
720 checkPatField (n,e) = do
724 patFail loc = parseError loc "Parse error in pattern"
727 ---------------------------------------------------------------------------
728 -- Check Equation Syntax
732 -> Maybe (LHsType RdrName)
734 -> P (HsBind RdrName)
736 checkValDef lhs opt_sig grhss
737 | Just (f,inf,es) <- isFunLhs lhs []
738 = if isQual (unLoc f)
739 then parseError (getLoc f) ("Qualified name in function definition: " ++
740 showRdrName (unLoc f))
741 else do ps <- checkPatterns es
742 return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
743 -- TODO: span is wrong
745 lhs <- checkPattern lhs
746 return (PatBind lhs grhss)
752 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
753 checkValSig (L l other) ty
754 = parseError l "Type signature given for an expression"
756 -- A variable binding is parsed as a FunBind.
758 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
759 -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
760 isFunLhs (L loc e) = isFunLhs' loc e
762 isFunLhs' loc (HsVar f) es
763 | not (isRdrDataCon f) = Just (L loc f, False, es)
764 isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es)
765 isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es
766 isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
767 | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
769 case isFunLhs l es of
770 Just (op', True, j : k : es') ->
772 j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
774 isFunLhs' _ _ _ = Nothing
776 ---------------------------------------------------------------------------
777 -- Miscellaneous utilities
779 checkPrecP :: Located Int -> P Int
781 | 0 <= i && i <= maxPrecedence = return i
782 | otherwise = parseError l "Precedence out of range"
787 -> HsRecordBinds RdrName
788 -> P (HsExpr RdrName)
790 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
791 = return (RecordCon (L l c) fs)
792 mkRecConstrOrUpdate exp loc fs@(_:_)
793 = return (RecordUpd exp fs)
794 mkRecConstrOrUpdate _ loc []
795 = parseError loc "Empty record update"
797 -----------------------------------------------------------------------------
798 -- utilities for foreign declarations
800 -- supported calling conventions
802 data CallConv = CCall CCallConv -- ccall or stdcall
805 -- construct a foreign import declaration
809 -> (Located FastString, Located RdrName, LHsType RdrName)
810 -> P (HsDecl RdrName)
811 mkImport (CCall cconv) safety (entity, v, ty) = do
812 importSpec <- parseCImport entity cconv safety v
813 return (ForD (ForeignImport v ty importSpec False))
814 mkImport (DNCall ) _ (entity, v, ty) = do
815 spec <- parseDImport entity
816 return $ ForD (ForeignImport v ty (DNImport spec) False)
818 -- parse the entity string of a foreign import declaration for the `ccall' or
819 -- `stdcall' calling convention'
821 parseCImport :: Located FastString
826 parseCImport (L loc entity) cconv safety v
827 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
828 | entity == FSLIT ("dynamic") =
829 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
830 | entity == FSLIT ("wrapper") =
831 return $ CImport cconv safety nilFS nilFS CWrapper
832 | otherwise = parse0 (unpackFS entity)
834 -- using the static keyword?
835 parse0 (' ': rest) = parse0 rest
836 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
837 parse0 rest = parse1 rest
838 -- check for header file name
839 parse1 "" = parse4 "" nilFS False nilFS
840 parse1 (' ':rest) = parse1 rest
841 parse1 str@('&':_ ) = parse2 str nilFS
842 parse1 str@('[':_ ) = parse3 str nilFS False
844 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
845 | otherwise = parse4 str nilFS False nilFS
847 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
848 -- check for address operator (indicating a label import)
849 parse2 "" header = parse4 "" header False nilFS
850 parse2 (' ':rest) header = parse2 rest header
851 parse2 ('&':rest) header = parse3 rest header True
852 parse2 str@('[':_ ) header = parse3 str header False
853 parse2 str header = parse4 str header False nilFS
854 -- check for library object name
855 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
856 parse3 ('[':rest) header isLbl =
857 case break (== ']') rest of
858 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
859 _ -> parseError loc "Missing ']' in entity"
860 parse3 str header isLbl = parse4 str header isLbl nilFS
861 -- check for name of C function
862 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
863 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
864 parse4 str header isLbl lib
865 | all (== ' ') rest = build (mkFastString first) header isLbl lib
866 | otherwise = parseError loc "Malformed entity string"
868 (first, rest) = break (== ' ') str
870 build cid header False lib = return $
871 CImport cconv safety header lib (CFunction (StaticTarget cid))
872 build cid header True lib = return $
873 CImport cconv safety header lib (CLabel cid )
876 -- Unravel a dotnet spec string.
878 parseDImport :: Located FastString -> P DNCallSpec
879 parseDImport (L loc entity) = parse0 comps
881 comps = words (unpackFS entity)
885 | x == "static" = parse1 True xs
886 | otherwise = parse1 False (x:xs)
889 parse1 isStatic (x:xs)
890 | x == "method" = parse2 isStatic DNMethod xs
891 | x == "field" = parse2 isStatic DNField xs
892 | x == "ctor" = parse2 isStatic DNConstructor xs
893 parse1 isStatic xs = parse2 isStatic DNMethod xs
896 parse2 isStatic kind (('[':x):xs) =
899 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
900 parse2 isStatic kind xs = parse3 isStatic kind "" xs
902 parse3 isStatic kind assem [x] =
903 return (DNCallSpec isStatic kind assem x
904 -- these will be filled in once known.
905 (error "FFI-dotnet-args")
906 (error "FFI-dotnet-result"))
907 parse3 _ _ _ _ = d'oh
909 d'oh = parseError loc "Malformed entity string"
911 -- construct a foreign export declaration
914 -> (Located FastString, Located RdrName, LHsType RdrName)
915 -> P (HsDecl RdrName)
916 mkExport (CCall cconv) (L loc entity, v, ty) = return $
917 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
919 entity' | nullFastString entity = mkExtName (unLoc v)
921 mkExport DNCall (L loc entity, v, ty) =
922 parseError (getLoc v){-TODO: not quite right-}
923 "Foreign export is not yet supported for .NET"
925 -- Supplying the ext_name in a foreign decl is optional; if it
926 -- isn't there, the Haskell name is assumed. Note that no transformation
927 -- of the Haskell name is then performed, so if you foreign export (++),
928 -- it's external name will be "++". Too bad; it's important because we don't
929 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
930 -- (This is why we use occNameUserString.)
932 mkExtName :: RdrName -> CLabelString
933 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
937 -----------------------------------------------------------------------------
941 showRdrName :: RdrName -> String
942 showRdrName r = showSDoc (ppr r)
944 parseError :: SrcSpan -> String -> P a
945 parseError span s = failSpanMsgP span s