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 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 )
68 import TyCon ( DataConDetails(..) )
69 import Module ( ModuleName )
71 import CStrings ( CLabelString )
72 import CmdLineOpts ( opt_InPackage )
73 import OrdList ( OrdList, fromOL )
74 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
79 import List ( isSuffixOf, nubBy )
83 %************************************************************************
85 \subsection{A few functions over HsSyn at RdrName}
87 %************************************************************************
89 extractHsTyRdrNames finds the free variables of a HsType
90 It's used when making the for-alls explicit.
93 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
94 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
96 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
97 -- This one takes the context and tau-part of a
98 -- sigma type and returns their free type variables
99 extractHsRhoRdrTyVars ctxt ty
100 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
102 extract_lctxt ctxt acc = foldr (extract_pred.unLoc) acc (unLoc ctxt)
104 extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
105 extract_pred (HsIParam n ty) acc = extract_lty ty acc
107 extract_lty (L loc (HsTyVar tv)) acc
108 | isRdrTyVar tv = L loc tv : acc
110 extract_lty ty acc = extract_ty (unLoc ty) acc
112 extract_ty (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
113 extract_ty (HsListTy ty) acc = extract_lty ty acc
114 extract_ty (HsPArrTy ty) acc = extract_lty ty acc
115 extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys
116 extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
117 extract_ty (HsPredTy p) acc = extract_pred (unLoc p) acc
118 extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
119 extract_ty (HsParTy ty) acc = extract_lty ty acc
120 extract_ty (HsNumTy num) acc = acc
121 extract_ty (HsSpliceTy _) acc = acc -- Type splices mention no type variables
122 extract_ty (HsKindSig ty k) acc = extract_lty ty acc
123 extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
124 extract_ty (HsForAllTy exp tvs cx ty)
125 acc = (filter ((`notElem` locals) . unLoc) $
126 extract_lctxt cx (extract_lty ty [])) ++ acc
128 locals = hsLTyVarNames tvs
130 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
131 -- Get the type variables out of the type patterns in a bunch of
132 -- possibly-generic bindings in a class declaration
133 extractGenericPatTyVars binds
134 = nubBy eqLocated (foldrBag get [] binds)
136 get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms
139 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
140 get_m other acc = acc
144 %************************************************************************
146 \subsection{Construction functions for Rdr stuff}
148 %************************************************************************
150 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
151 by deriving them from the name of the class. We fill in the names for the
152 tycon and datacon corresponding to the class, by deriving them from the
153 name of the class itself. This saves recording the names in the interface
154 file (which would be equally good).
156 Similarly for mkConDecl, mkClassOpSig and default-method names.
158 *** See "THE NAMING STORY" in HsDecls ****
161 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
162 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
168 mkTyData new_or_data (context, tname, tyvars) data_cons maybe
169 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
170 tcdTyVars = tyvars, tcdCons = data_cons,
175 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
176 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
177 -- can't take an unboxed arg. But that is exactly what it will see when
178 -- we write "-3#". So we have to do the negation right now!
179 mkHsNegApp (L loc e) = f e
180 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
181 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
182 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
183 f expr = NegApp (L loc e) placeHolderName
186 %************************************************************************
190 %************************************************************************
192 mkBootIface, and its boring helper functions, have two purposes:
193 a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
194 an hi-boot file, and interfaces consist of the latter
195 b) Convert unqualifed names from the "current module" to qualified Orig
198 foo :: GHC.Base.Int -> GHC.Base.Int
200 This.foo :: GHC.Base.Int -> GHC.Base.Int
202 It assumes that everything is well kinded, of course.
205 mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
206 -- Make the ModIface for a hi-boot file
207 -- The decls are of very limited form
208 mkBootIface mod decls
209 = (emptyModIface opt_InPackage mod) {
211 mi_exports = [(mod, map mk_export decls')],
212 mi_decls = decls_w_vers,
213 mi_ver_fn = mkIfaceVerCache decls_w_vers }
215 decls' = map hsIfaceDecl decls
216 decls_w_vers = repeat initialVersion `zip` decls'
218 -- hi-boot declarations don't (currently)
219 -- expose constructors or class methods
220 mk_export decl | isValOcc occ = Avail occ
221 | otherwise = AvailTC occ [occ]
226 hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
227 -- Change to Iface syntax, and replace unqualified names with
228 -- qualified Orig names from this module. Reason: normal
229 -- iface files have everything fully qualified, so it's convenient
230 -- for hi-boot files to look the same
232 -- NB: no constructors or class ops to worry about
233 hsIfaceDecl (SigD (Sig name ty))
234 = IfaceId { ifName = rdrNameOcc (unLoc name),
235 ifType = hsIfaceLType ty,
238 hsIfaceDecl (TyClD decl@(TySynonym {}))
239 = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
240 ifTyVars = hsIfaceTvs (tcdTyVars decl),
241 ifSynRhs = hsIfaceLType (tcdSynRhs decl),
244 hsIfaceDecl (TyClD decl@(TyData {}))
245 = IfaceData { ifND = tcdND decl,
246 ifName = rdrNameOcc (tcdName decl),
247 ifTyVars = hsIfaceTvs (tcdTyVars decl),
248 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
249 ifCons = Unknown, ifRec = NonRecursive,
250 ifVrcs = [], ifGeneric = False }
251 -- I'm not sure that [] is right for ifVrcs, but
252 -- since we don't use them I'm not going to fiddle
254 hsIfaceDecl (TyClD decl@(ClassDecl {}))
255 = IfaceClass { ifName = rdrNameOcc (tcdName decl),
256 ifTyVars = hsIfaceTvs (tcdTyVars decl),
257 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
258 ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
259 ifSigs = [], -- Is this right??
260 ifRec = NonRecursive, ifVrcs = [] }
262 hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
264 hsIfaceName rdr_name -- Qualify unqualifed occurrences
265 -- with the module name
266 | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
267 | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
269 hsIfaceLType :: LHsType RdrName -> IfaceType
270 hsIfaceLType = hsIfaceType . unLoc
272 hsIfaceType :: HsType RdrName -> IfaceType
273 hsIfaceType (HsForAllTy exp tvs cxt ty)
274 = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
276 rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
277 tau = hsIfaceLType ty
279 Explicit -> map unLoc tvs
280 Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
282 hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
283 hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
284 hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
285 hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t]
286 hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
287 hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
288 hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
289 hsIfaceType (HsParTy t) = hsIfaceLType t
290 hsIfaceType (HsPredTy p) = IfacePredTy (hsIfaceLPred p)
291 hsIfaceType (HsKindSig t _) = hsIfaceLType t
292 hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
293 hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy"
296 hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
299 hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
300 hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
303 hsIfaceLPred :: LHsPred RdrName -> IfacePredType
304 hsIfaceLPred = hsIfacePred . unLoc
306 hsIfacePred :: HsPred RdrName -> IfacePredType
307 hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
308 hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
311 hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
312 hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
313 hs_tc_app (HsTyVar n) args
314 | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
315 | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
316 hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
319 hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
322 hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind)
323 hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
326 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
327 hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
331 %************************************************************************
333 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
335 %************************************************************************
337 Function definitions are restructured here. Each is assumed to be recursive
338 initially, and non recursive definitions are discovered by the dependency
343 -- | Groups together bindings for a single function
344 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
345 cvTopDecls decls = go (fromOL decls)
347 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
349 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
350 where (L l' b', ds') = getMonoBind (L l b) ds
351 go (d : ds) = d : go ds
353 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
355 = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
356 HsBindGroup mbs sigs Recursive -- just one big group for now
359 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
360 -> (Bag (LHsBind RdrName), [LSig RdrName])
361 -- Input decls contain just value bindings and signatures
362 cvBindsAndSigs fb = go (fromOL fb)
364 go [] = (emptyBag, [])
365 go (L l (SigD s) : ds) = (bs, L l s : ss)
366 where (bs,ss) = go ds
367 go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
368 where (b',ds') = getMonoBind (L l b) ds
371 -----------------------------------------------------------------------------
372 -- Group function bindings into equation groups
374 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
375 -> (LHsBind RdrName, [LHsDecl RdrName])
376 -- Suppose (b',ds') = getMonoBind b ds
377 -- ds is a *reversed* list of parsed bindings
378 -- b is a MonoBinds that has just been read off the front
380 -- Then b' is the result of grouping more equations from ds that
381 -- belong with b into a single MonoBinds, and ds' is the depleted
382 -- list of parsed bindings.
384 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
386 getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
390 go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
391 | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
392 where loc = combineSrcSpans loc1 loc2
394 = (L loc (FunBind lf inf (reverse mtchs1)), binds)
395 -- reverse the final matches, to get it back in the right order
397 getMonoBind bind binds = (bind, binds)
399 has_args ((L _ (Match args _ _)) : _) = not (null args)
400 -- Don't group together FunBinds if they have
401 -- no arguments. This is necessary now that variable bindings
402 -- with no arguments are now treated as FunBinds rather
403 -- than pattern bindings (tests/rename/should_fail/rnfail002).
407 emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
408 hs_tyclds = [], hs_instds = [],
409 hs_fixds = [], hs_defds = [], hs_fords = [],
410 hs_depds = [] ,hs_ruleds = [] }
412 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
413 findSplice ds = addl emptyGroup ds
415 mkGroup :: [LHsDecl a] -> HsGroup a
416 mkGroup ds = addImpDecls emptyGroup ds
418 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
419 -- The decls are imported, and should not have a splice
420 addImpDecls group decls = case addl group decls of
421 (group', Nothing) -> group'
422 other -> panic "addImpDecls"
424 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
425 -- This stuff reverses the declarations (again) but it doesn't matter
428 addl gp [] = (gp, Nothing)
429 addl gp (L l d : ds) = add gp l d ds
432 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
433 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
435 add gp l (SpliceD e) ds = (gp, Just (e, ds))
437 -- Class declarations: pull out the fixity signatures to the top
438 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
440 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
441 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
443 addl (gp { hs_tyclds = L l d : ts }) ds
445 -- Signatures: fixity sigs go a different place than all others
446 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
447 = addl (gp {hs_fixds = L l f : ts}) ds
448 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
449 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
451 -- Value declarations: use add_bind
452 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
453 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
455 -- The rest are routine
456 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
457 = addl (gp { hs_instds = L l d : ts }) ds
458 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
459 = addl (gp { hs_defds = L l d : ts }) ds
460 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
461 = addl (gp { hs_fords = L l d : ts }) ds
462 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
463 = addl (gp { hs_depds = L l d : ts }) ds
464 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
465 = addl (gp { hs_ruleds = L l d : ts }) ds
467 add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r]
468 add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r]
471 %************************************************************************
473 \subsection[PrefixToHS-utils]{Utilities for conversion}
475 %************************************************************************
479 -----------------------------------------------------------------------------
482 -- When parsing data declarations, we sometimes inadvertently parse
483 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
484 -- This function splits up the type application, adds any pending
485 -- arguments, and converts the type constructor back into a data constructor.
487 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
488 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
492 split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
493 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
494 return (data_con, PrefixCon ts)
495 split (L l _) _ = parseError l "parse error in data/newtype declaration"
497 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
498 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
499 mkRecCon (L loc con) fields
500 = do data_con <- tyConToDataCon loc con
501 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
503 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
504 tyConToDataCon loc tc
505 | isTcOcc (rdrNameOcc tc)
506 = return (L loc (setRdrNameSpace tc srcDataName))
508 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
510 ----------------------------------------------------------------------------
511 -- Various Syntactic Checks
513 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
514 checkInstType (L l t)
516 HsForAllTy exp tvs ctxt ty -> do
517 dict_ty <- checkDictTy ty
518 return (L l (HsForAllTy exp tvs ctxt dict_ty))
520 HsParTy ty -> checkInstType ty
522 ty -> do dict_ty <- checkDictTy (L l ty)
523 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
525 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
529 -- Check that the name space is correct!
530 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
531 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
532 chk (L l (HsTyVar tv))
533 | isRdrTyVar tv = return (L l (UserTyVar tv))
535 = parseError l "Type found where type variable expected"
537 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
538 -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
539 -- The header of a type or class decl should look like
540 -- (C a, D b) => T a b
544 checkTyClHdr (L l cxt) ty
545 = do (tc, tvs) <- gol ty []
547 return (L l cxt, tc, tvs)
549 gol (L l ty) acc = go l ty acc
551 go l (HsTyVar tc) acc
552 | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
554 go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
556 go l (HsParTy ty) acc = gol ty acc
557 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
558 go l other acc = parseError l "Malformed LHS to type of class declaration"
560 -- The predicates in a type or class decl must all
561 -- be HsClassPs. They need not all be type variables,
562 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
563 chk_pred (L l (HsClassP _ args)) = return ()
565 = parseError l "Malformed context in type or class declaration"
568 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
572 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
573 = do ctx <- mapM checkPred ts
576 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
579 check (HsTyVar t) -- Empty context shows up as a unit type ()
580 | t == getRdrName unitTyCon = return (L l [])
583 = do p <- checkPred (L l t)
587 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
588 -- Watch out.. in ...deriving( Show )... we use checkPred on
589 -- the list of partially applied predicates in the deriving,
590 -- so there can be zero args.
591 checkPred (L spn (HsPredTy (L _ (HsIParam n ty))) )
592 = return (L spn (HsIParam n ty))
596 checkl (L l ty) args = check l ty args
598 check loc (HsTyVar t) args | not (isRdrTyVar t)
599 = return (L spn (HsClassP t args))
600 check loc (HsAppTy l r) args = checkl l (r:args)
601 check loc (HsParTy t) args = checkl t args
602 check loc _ _ = parseError loc "malformed class assertion"
604 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
605 checkDictTy (L spn ty) = check ty []
607 check (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
608 = return (L spn (HsPredTy (L spn (HsClassP t args))))
609 check (HsAppTy l r) args = check (unLoc l) (r:args)
610 check (HsParTy t) args = check (unLoc t) args
611 check _ _ = parseError spn "Malformed context in instance header"
613 ---------------------------------------------------------------------------
614 -- Checking statements in a do-expression
615 -- We parse do { e1 ; e2 ; }
616 -- as [ExprStmt e1, ExprStmt e2]
617 -- checkDo (a) checks that the last thing is an ExprStmt
618 -- (b) transforms it to a ResultStmt
619 -- same comments apply for mdo as well
621 checkDo = checkDoMDo "a " "'do'"
622 checkMDo = checkDoMDo "an " "'mdo'"
624 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
625 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
626 checkDoMDo pre nm loc ss = do
629 check [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
630 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
631 " construct must be an expression")
636 -- -------------------------------------------------------------------------
637 -- Checking Patterns.
639 -- We parse patterns as expressions and check for valid patterns below,
640 -- converting the expression into a pattern at the same time.
642 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
643 checkPattern e = checkLPat e
645 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
646 checkPatterns es = mapM checkPattern es
648 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
649 checkLPat e@(L l _) = checkPat l e []
651 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
652 checkPat loc (L l (HsVar c)) args
653 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
654 checkPat loc (L _ (HsApp f x)) args = do
656 checkPat loc f (x:args)
657 checkPat loc (L _ e) [] = do
660 checkPat loc pat _some_args
663 checkAPat loc e = case e of
664 EWildPat -> return (WildPat placeHolderType)
665 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
667 | otherwise -> return (VarPat x)
668 HsLit l -> return (LitPat l)
670 -- Overloaded numeric patterns (e.g. f 0 x = x)
671 -- Negation is recorded separately, so that the literal is zero or +ve
672 -- NB. Negative *primitive* literals are already handled by
673 -- RdrHsSyn.mkHsNegApp
674 HsOverLit pos_lit -> return (NPatIn pos_lit Nothing)
675 NegApp (L _ (HsOverLit pos_lit)) _
676 -> return (NPatIn pos_lit (Just placeHolderName))
678 ELazyPat e -> checkLPat e >>= (return . LazyPat)
679 EAsPat n e -> checkLPat e >>= (return . AsPat n)
680 ExprWithTySig e t -> checkLPat e >>= \e ->
681 -- Pattern signatures are parsed as sigtypes,
682 -- but they aren't explicit forall points. Hence
683 -- we have to remove the implicit forall here.
685 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
688 return (SigPatIn e t')
691 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
692 (L _ (HsOverLit lit@(HsIntegral _ _)))
694 -> return (mkNPlusKPat (L nloc n) lit)
696 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
698 OpApp l op fix r -> checkLPat l >>= \l ->
699 checkLPat r >>= \r ->
701 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
702 -> return (ConPatIn (L cl c) (InfixCon l r))
705 HsPar e -> checkLPat e >>= (return . ParPat)
706 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
707 return (ListPat ps placeHolderType)
708 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
709 return (PArrPat ps placeHolderType)
711 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
712 return (TuplePat ps b)
714 RecordCon c fs -> mapM checkPatField fs >>= \fs ->
715 return (ConPatIn c (RecCon fs))
717 HsType ty -> return (TypePat ty)
720 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
721 checkPatField (n,e) = do
725 patFail loc = parseError loc "Parse error in pattern"
728 ---------------------------------------------------------------------------
729 -- Check Equation Syntax
733 -> Maybe (LHsType RdrName)
735 -> P (HsBind RdrName)
737 checkValDef lhs opt_sig grhss
738 | Just (f,inf,es) <- isFunLhs lhs []
739 = if isQual (unLoc f)
740 then parseError (getLoc f) ("Qualified name in function definition: " ++
741 showRdrName (unLoc f))
742 else do ps <- checkPatterns es
743 return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
744 -- TODO: span is wrong
746 lhs <- checkPattern lhs
747 return (PatBind lhs grhss)
753 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
754 checkValSig (L l other) ty
755 = parseError l "Type signature given for an expression"
757 -- A variable binding is parsed as a FunBind.
759 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
760 -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
761 isFunLhs (L loc e) = isFunLhs' loc e
763 isFunLhs' loc (HsVar f) es
764 | not (isRdrDataCon f) = Just (L loc f, False, es)
765 isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es)
766 isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es
767 isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
768 | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
770 case isFunLhs l es of
771 Just (op', True, j : k : es') ->
773 j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
775 isFunLhs' _ _ _ = Nothing
777 ---------------------------------------------------------------------------
778 -- Miscellaneous utilities
780 checkPrecP :: Located Int -> P Int
782 | 0 <= i && i <= maxPrecedence = return i
783 | otherwise = parseError l "Precedence out of range"
788 -> HsRecordBinds RdrName
789 -> P (HsExpr RdrName)
791 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
792 = return (RecordCon (L l c) fs)
793 mkRecConstrOrUpdate exp loc fs@(_:_)
794 = return (RecordUpd exp fs)
795 mkRecConstrOrUpdate _ loc []
796 = parseError loc "Empty record update"
798 -----------------------------------------------------------------------------
799 -- utilities for foreign declarations
801 -- supported calling conventions
803 data CallConv = CCall CCallConv -- ccall or stdcall
806 -- construct a foreign import declaration
810 -> (Located FastString, Located RdrName, LHsType RdrName)
811 -> P (HsDecl RdrName)
812 mkImport (CCall cconv) safety (entity, v, ty) = do
813 importSpec <- parseCImport entity cconv safety v
814 return (ForD (ForeignImport v ty importSpec False))
815 mkImport (DNCall ) _ (entity, v, ty) = do
816 spec <- parseDImport entity
817 return $ ForD (ForeignImport v ty (DNImport spec) False)
819 -- parse the entity string of a foreign import declaration for the `ccall' or
820 -- `stdcall' calling convention'
822 parseCImport :: Located FastString
827 parseCImport (L loc entity) cconv safety v
828 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
829 | entity == FSLIT ("dynamic") =
830 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
831 | entity == FSLIT ("wrapper") =
832 return $ CImport cconv safety nilFS nilFS CWrapper
833 | otherwise = parse0 (unpackFS entity)
835 -- using the static keyword?
836 parse0 (' ': rest) = parse0 rest
837 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
838 parse0 rest = parse1 rest
839 -- check for header file name
840 parse1 "" = parse4 "" nilFS False nilFS
841 parse1 (' ':rest) = parse1 rest
842 parse1 str@('&':_ ) = parse2 str nilFS
843 parse1 str@('[':_ ) = parse3 str nilFS False
845 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
846 | otherwise = parse4 str nilFS False nilFS
848 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
849 -- check for address operator (indicating a label import)
850 parse2 "" header = parse4 "" header False nilFS
851 parse2 (' ':rest) header = parse2 rest header
852 parse2 ('&':rest) header = parse3 rest header True
853 parse2 str@('[':_ ) header = parse3 str header False
854 parse2 str header = parse4 str header False nilFS
855 -- check for library object name
856 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
857 parse3 ('[':rest) header isLbl =
858 case break (== ']') rest of
859 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
860 _ -> parseError loc "Missing ']' in entity"
861 parse3 str header isLbl = parse4 str header isLbl nilFS
862 -- check for name of C function
863 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
864 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
865 parse4 str header isLbl lib
866 | all (== ' ') rest = build (mkFastString first) header isLbl lib
867 | otherwise = parseError loc "Malformed entity string"
869 (first, rest) = break (== ' ') str
871 build cid header False lib = return $
872 CImport cconv safety header lib (CFunction (StaticTarget cid))
873 build cid header True lib = return $
874 CImport cconv safety header lib (CLabel cid )
877 -- Unravel a dotnet spec string.
879 parseDImport :: Located FastString -> P DNCallSpec
880 parseDImport (L loc entity) = parse0 comps
882 comps = words (unpackFS entity)
886 | x == "static" = parse1 True xs
887 | otherwise = parse1 False (x:xs)
890 parse1 isStatic (x:xs)
891 | x == "method" = parse2 isStatic DNMethod xs
892 | x == "field" = parse2 isStatic DNField xs
893 | x == "ctor" = parse2 isStatic DNConstructor xs
894 parse1 isStatic xs = parse2 isStatic DNMethod xs
897 parse2 isStatic kind (('[':x):xs) =
900 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
901 parse2 isStatic kind xs = parse3 isStatic kind "" xs
903 parse3 isStatic kind assem [x] =
904 return (DNCallSpec isStatic kind assem x
905 -- these will be filled in once known.
906 (error "FFI-dotnet-args")
907 (error "FFI-dotnet-result"))
908 parse3 _ _ _ _ = d'oh
910 d'oh = parseError loc "Malformed entity string"
912 -- construct a foreign export declaration
915 -> (Located FastString, Located RdrName, LHsType RdrName)
916 -> P (HsDecl RdrName)
917 mkExport (CCall cconv) (L loc entity, v, ty) = return $
918 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
920 entity' | nullFastString entity = mkExtName (unLoc v)
922 mkExport DNCall (L loc entity, v, ty) =
923 parseError (getLoc v){-TODO: not quite right-}
924 "Foreign export is not yet supported for .NET"
926 -- Supplying the ext_name in a foreign decl is optional; if it
927 -- isn't there, the Haskell name is assumed. Note that no transformation
928 -- of the Haskell name is then performed, so if you foreign export (++),
929 -- it's external name will be "++". Too bad; it's important because we don't
930 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
931 -- (This is why we use occNameUserString.)
933 mkExtName :: RdrName -> CLabelString
934 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
938 -----------------------------------------------------------------------------
942 showRdrName :: RdrName -> String
943 showRdrName r = showSDoc (ppr r)
945 parseError :: SrcSpan -> String -> P a
946 parseError span s = failSpanMsgP span s