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
22 -- Stuff to do with Foreign declarations
24 , mkImport -- CallConv -> Safety
25 -- -> (FastString, RdrName, RdrNameHsType)
27 , mkExport -- CallConv
28 -- -> (FastString, RdrName, RdrNameHsType)
30 , mkExtName -- RdrName -> CLabelString
32 -- Bunch of functions in the parser monad for
33 -- checking and constructing values
34 , checkPrecP -- Int -> P Int
35 , checkContext -- HsType -> P HsContext
36 , checkPred -- HsType -> P HsPred
37 , checkTyClHdr -- HsType -> (name,[tyvar])
38 , checkInstType -- HsType -> P HsType
39 , checkPattern -- HsExp -> P HsPat
40 , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
41 , checkDo -- [Stmt] -> P [Stmt]
42 , checkMDo -- [Stmt] -> P [Stmt]
43 , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
44 , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
45 , parseError -- String -> Pa
48 #include "HsVersions.h"
50 import HsSyn -- Lots of it
52 import Packages ( PackageIdH(..) )
53 import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache,
54 Dependencies(..), IsBootInterface, noDependencies )
55 import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) )
56 import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
57 isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
58 setRdrNameSpace, rdrNameModule )
59 import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
60 import Lexer ( P, failSpanMsgP )
61 import Kind ( liftedTypeKind )
62 import HscTypes ( GenAvailInfo(..) )
63 import TysWiredIn ( unitTyCon )
64 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
65 DNCallSpec(..), DNKind(..), CLabelString )
66 import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
67 occNameUserString, isValOcc )
68 import BasicTypes ( initialVersion, StrictnessMark(..) )
69 import Module ( Module )
71 import OrdList ( OrdList, fromOL )
72 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
77 import List ( isSuffixOf, nubBy )
81 %************************************************************************
83 \subsection{A few functions over HsSyn at RdrName}
85 %************************************************************************
87 extractHsTyRdrNames finds the free variables of a HsType
88 It's used when making the for-alls explicit.
91 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
92 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
94 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
95 -- This one takes the context and tau-part of a
96 -- sigma type and returns their free type variables
97 extractHsRhoRdrTyVars ctxt ty
98 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
100 extract_lctxt ctxt acc = foldr (extract_pred.unLoc) acc (unLoc ctxt)
102 extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
103 extract_pred (HsIParam n ty) acc = extract_lty ty acc
105 extract_lty (L loc (HsTyVar tv)) acc
106 | isRdrTyVar tv = L loc tv : acc
108 extract_lty ty acc = extract_ty (unLoc ty) acc
110 extract_ty (HsBangTy _ ty) acc = extract_lty ty acc
111 extract_ty (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
112 extract_ty (HsListTy ty) acc = extract_lty ty acc
113 extract_ty (HsPArrTy ty) acc = extract_lty ty acc
114 extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys
115 extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
116 extract_ty (HsPredTy p) acc = extract_pred p acc
117 extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
118 extract_ty (HsParTy ty) acc = extract_lty ty acc
119 extract_ty (HsNumTy num) acc = acc
120 extract_ty (HsSpliceTy _) acc = acc -- Type splices mention no type variables
121 extract_ty (HsKindSig ty k) acc = extract_lty ty acc
122 extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
123 extract_ty (HsForAllTy exp tvs cx ty)
124 acc = (filter ((`notElem` locals) . unLoc) $
125 extract_lctxt cx (extract_lty ty [])) ++ acc
127 locals = hsLTyVarNames tvs
129 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
130 -- Get the type variables out of the type patterns in a bunch of
131 -- possibly-generic bindings in a class declaration
132 extractGenericPatTyVars binds
133 = nubBy eqLocated (foldrBag get [] binds)
135 get (L _ (FunBind _ _ (MatchGroup ms _))) acc = foldr (get_m.unLoc) acc ms
138 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
139 get_m other acc = acc
143 %************************************************************************
145 \subsection{Construction functions for Rdr stuff}
147 %************************************************************************
149 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
150 by deriving them from the name of the class. We fill in the names for the
151 tycon and datacon corresponding to the class, by deriving them from the
152 name of the class itself. This saves recording the names in the interface
153 file (which would be equally good).
155 Similarly for mkConDecl, mkClassOpSig and default-method names.
157 *** See "THE NAMING STORY" in HsDecls ****
160 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
161 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
167 mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv
168 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
169 tcdTyVars = tyvars, tcdCons = data_cons,
170 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
174 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
175 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
176 -- can't take an unboxed arg. But that is exactly what it will see when
177 -- we write "-3#". So we have to do the negation right now!
178 mkHsNegApp (L loc e) = f e
179 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
180 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
181 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
182 f expr = NegApp (L loc e) placeHolderName
185 %************************************************************************
187 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
189 %************************************************************************
191 Function definitions are restructured here. Each is assumed to be recursive
192 initially, and non recursive definitions are discovered by the dependency
197 -- | Groups together bindings for a single function
198 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
199 cvTopDecls decls = go (fromOL decls)
201 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
203 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
204 where (L l' b', ds') = getMonoBind (L l b) ds
205 go (d : ds) = d : go ds
207 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
209 = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
210 HsBindGroup mbs sigs Recursive -- just one big group for now
213 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
214 -> (Bag (LHsBind RdrName), [LSig RdrName])
215 -- Input decls contain just value bindings and signatures
216 cvBindsAndSigs fb = go (fromOL fb)
218 go [] = (emptyBag, [])
219 go (L l (SigD s) : ds) = (bs, L l s : ss)
220 where (bs,ss) = go ds
221 go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
222 where (b',ds') = getMonoBind (L l b) ds
225 -----------------------------------------------------------------------------
226 -- Group function bindings into equation groups
228 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
229 -> (LHsBind RdrName, [LHsDecl RdrName])
230 -- Suppose (b',ds') = getMonoBind b ds
231 -- ds is a *reversed* list of parsed bindings
232 -- b is a MonoBinds that has just been read off the front
234 -- Then b' is the result of grouping more equations from ds that
235 -- belong with b into a single MonoBinds, and ds' is the depleted
236 -- list of parsed bindings.
238 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
241 getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds
245 go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds)
246 | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
247 where loc = combineSrcSpans loc1 loc2
249 = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds)
250 -- reverse the final matches, to get it back in the right order
252 getMonoBind bind binds = (bind, binds)
254 has_args ((L _ (Match args _ _)) : _) = not (null args)
255 -- Don't group together FunBinds if they have
256 -- no arguments. This is necessary now that variable bindings
257 -- with no arguments are now treated as FunBinds rather
258 -- than pattern bindings (tests/rename/should_fail/rnfail002).
262 emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
263 hs_tyclds = [], hs_instds = [],
264 hs_fixds = [], hs_defds = [], hs_fords = [],
265 hs_depds = [] ,hs_ruleds = [] }
267 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
268 findSplice ds = addl emptyGroup ds
270 mkGroup :: [LHsDecl a] -> HsGroup a
271 mkGroup ds = addImpDecls emptyGroup ds
273 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
274 -- The decls are imported, and should not have a splice
275 addImpDecls group decls = case addl group decls of
276 (group', Nothing) -> group'
277 other -> panic "addImpDecls"
279 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
280 -- This stuff reverses the declarations (again) but it doesn't matter
283 addl gp [] = (gp, Nothing)
284 addl gp (L l d : ds) = add gp l d ds
287 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
288 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
290 add gp l (SpliceD e) ds = (gp, Just (e, ds))
292 -- Class declarations: pull out the fixity signatures to the top
293 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
295 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
296 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
298 addl (gp { hs_tyclds = L l d : ts }) ds
300 -- Signatures: fixity sigs go a different place than all others
301 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
302 = addl (gp {hs_fixds = L l f : ts}) ds
303 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
304 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
306 -- Value declarations: use add_bind
307 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
308 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
310 -- The rest are routine
311 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
312 = addl (gp { hs_instds = L l d : ts }) ds
313 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
314 = addl (gp { hs_defds = L l d : ts }) ds
315 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
316 = addl (gp { hs_fords = L l d : ts }) ds
317 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
318 = addl (gp { hs_depds = L l d : ts }) ds
319 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
320 = addl (gp { hs_ruleds = L l d : ts }) ds
322 add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r]
323 add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r]
326 %************************************************************************
328 \subsection[PrefixToHS-utils]{Utilities for conversion}
330 %************************************************************************
334 -----------------------------------------------------------------------------
337 -- When parsing data declarations, we sometimes inadvertently parse
338 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
339 -- This function splits up the type application, adds any pending
340 -- arguments, and converts the type constructor back into a data constructor.
342 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
343 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
347 split (L _ (HsAppTy t u)) ts = split t (u : ts)
348 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
349 return (data_con, PrefixCon ts)
350 split (L l _) _ = parseError l "parse error in data/newtype declaration"
352 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
353 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
354 mkRecCon (L loc con) fields
355 = do data_con <- tyConToDataCon loc con
356 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
358 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
359 tyConToDataCon loc tc
360 | isTcOcc (rdrNameOcc tc)
361 = return (L loc (setRdrNameSpace tc srcDataName))
363 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
365 ----------------------------------------------------------------------------
366 -- Various Syntactic Checks
368 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
369 checkInstType (L l t)
371 HsForAllTy exp tvs ctxt ty -> do
372 dict_ty <- checkDictTy ty
373 return (L l (HsForAllTy exp tvs ctxt dict_ty))
375 HsParTy ty -> checkInstType ty
377 ty -> do dict_ty <- checkDictTy (L l ty)
378 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
380 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
384 -- Check that the name space is correct!
385 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
386 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
387 chk (L l (HsTyVar tv))
388 | isRdrTyVar tv = return (L l (UserTyVar tv))
390 = parseError l "Type found where type variable expected"
392 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
393 -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
394 -- The header of a type or class decl should look like
395 -- (C a, D b) => T a b
399 checkTyClHdr (L l cxt) ty
400 = do (tc, tvs) <- gol ty []
402 return (L l cxt, tc, tvs)
404 gol (L l ty) acc = go l ty acc
406 go l (HsTyVar tc) acc
407 | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
409 go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
411 go l (HsParTy ty) acc = gol ty acc
412 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
413 go l other acc = parseError l "Malformed LHS to type of class declaration"
415 -- The predicates in a type or class decl must all
416 -- be HsClassPs. They need not all be type variables,
417 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
418 chk_pred (L l (HsClassP _ args)) = return ()
420 = parseError l "Malformed context in type or class declaration"
423 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
427 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
428 = do ctx <- mapM checkPred ts
431 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
434 check (HsTyVar t) -- Empty context shows up as a unit type ()
435 | t == getRdrName unitTyCon = return (L l [])
438 = do p <- checkPred (L l t)
442 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
443 -- Watch out.. in ...deriving( Show )... we use checkPred on
444 -- the list of partially applied predicates in the deriving,
445 -- so there can be zero args.
446 checkPred (L spn (HsPredTy (HsIParam n ty)))
447 = return (L spn (HsIParam n ty))
451 checkl (L l ty) args = check l ty args
453 check loc (HsTyVar t) args | not (isRdrTyVar t)
454 = return (L spn (HsClassP t args))
455 check loc (HsAppTy l r) args = checkl l (r:args)
456 check loc (HsParTy t) args = checkl t args
457 check loc _ _ = parseError loc "malformed class assertion"
459 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
460 checkDictTy (L spn ty) = check ty []
462 check (HsTyVar t) args | not (isRdrTyVar t)
463 = return (L spn (HsPredTy (HsClassP t args)))
464 check (HsAppTy l r) args = check (unLoc l) (r:args)
465 check (HsParTy t) args = check (unLoc t) args
466 check _ _ = parseError spn "Malformed context in instance header"
468 ---------------------------------------------------------------------------
469 -- Checking statements in a do-expression
470 -- We parse do { e1 ; e2 ; }
471 -- as [ExprStmt e1, ExprStmt e2]
472 -- checkDo (a) checks that the last thing is an ExprStmt
473 -- (b) transforms it to a ResultStmt
474 -- same comments apply for mdo as well
476 checkDo = checkDoMDo "a " "'do'"
477 checkMDo = checkDoMDo "an " "'mdo'"
479 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
480 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
481 checkDoMDo pre nm loc ss = do
484 check [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
485 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
486 " construct must be an expression")
491 -- -------------------------------------------------------------------------
492 -- Checking Patterns.
494 -- We parse patterns as expressions and check for valid patterns below,
495 -- converting the expression into a pattern at the same time.
497 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
498 checkPattern e = checkLPat e
500 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
501 checkPatterns es = mapM checkPattern es
503 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
504 checkLPat e@(L l _) = checkPat l e []
506 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
507 checkPat loc (L l (HsVar c)) args
508 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
509 checkPat loc (L _ (HsApp f x)) args = do
511 checkPat loc f (x:args)
512 checkPat loc (L _ e) [] = do
515 checkPat loc pat _some_args
518 checkAPat loc e = case e of
519 EWildPat -> return (WildPat placeHolderType)
520 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
522 | otherwise -> return (VarPat x)
523 HsLit l -> return (LitPat l)
525 -- Overloaded numeric patterns (e.g. f 0 x = x)
526 -- Negation is recorded separately, so that the literal is zero or +ve
527 -- NB. Negative *primitive* literals are already handled by
528 -- RdrHsSyn.mkHsNegApp
529 HsOverLit pos_lit -> return (NPatIn pos_lit Nothing)
530 NegApp (L _ (HsOverLit pos_lit)) _
531 -> return (NPatIn pos_lit (Just placeHolderName))
533 ELazyPat e -> checkLPat e >>= (return . LazyPat)
534 EAsPat n e -> checkLPat e >>= (return . AsPat n)
535 ExprWithTySig e t -> checkLPat e >>= \e ->
536 -- Pattern signatures are parsed as sigtypes,
537 -- but they aren't explicit forall points. Hence
538 -- we have to remove the implicit forall here.
540 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
543 return (SigPatIn e t')
546 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
547 (L _ (HsOverLit lit@(HsIntegral _ _)))
549 -> return (mkNPlusKPat (L nloc n) lit)
551 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
553 OpApp l op fix r -> checkLPat l >>= \l ->
554 checkLPat r >>= \r ->
556 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
557 -> return (ConPatIn (L cl c) (InfixCon l r))
560 HsPar e -> checkLPat e >>= (return . ParPat)
561 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
562 return (ListPat ps placeHolderType)
563 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
564 return (PArrPat ps placeHolderType)
566 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
567 return (TuplePat ps b)
569 RecordCon c fs -> mapM checkPatField fs >>= \fs ->
570 return (ConPatIn c (RecCon fs))
572 HsType ty -> return (TypePat ty)
575 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
576 checkPatField (n,e) = do
580 patFail loc = parseError loc "Parse error in pattern"
583 ---------------------------------------------------------------------------
584 -- Check Equation Syntax
588 -> Maybe (LHsType RdrName)
589 -> Located (GRHSs RdrName)
590 -> P (HsBind RdrName)
592 checkValDef lhs opt_sig (L rhs_span grhss)
593 | Just (f,inf,es) <- isFunLhs lhs []
594 = if isQual (unLoc f)
595 then parseError (getLoc f) ("Qualified name in function definition: " ++
596 showRdrName (unLoc f))
597 else do ps <- checkPatterns es
598 let match_span = combineSrcSpans (getLoc lhs) rhs_span
599 return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)]))
600 -- The span of the match covers the entire equation.
601 -- That isn't quite right, but it'll do for now.
603 lhs <- checkPattern lhs
604 return (PatBind lhs grhss placeHolderType)
610 checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
611 checkValSig (L l other) ty
612 = parseError l "Type signature given for an expression"
614 -- A variable binding is parsed as a FunBind.
616 isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
617 -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
618 isFunLhs (L loc e) = isFunLhs' loc e
620 isFunLhs' loc (HsVar f) es
621 | not (isRdrDataCon f) = Just (L loc f, False, es)
622 isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es)
623 isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es
624 isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
625 | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
627 case isFunLhs l es of
628 Just (op', True, j : k : es') ->
630 j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
632 isFunLhs' _ _ _ = Nothing
634 ---------------------------------------------------------------------------
635 -- Miscellaneous utilities
637 checkPrecP :: Located Int -> P Int
639 | 0 <= i && i <= maxPrecedence = return i
640 | otherwise = parseError l "Precedence out of range"
645 -> HsRecordBinds RdrName
646 -> P (HsExpr RdrName)
648 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
649 = return (RecordCon (L l c) fs)
650 mkRecConstrOrUpdate exp loc fs@(_:_)
651 = return (RecordUpd exp fs)
652 mkRecConstrOrUpdate _ loc []
653 = parseError loc "Empty record update"
655 -----------------------------------------------------------------------------
656 -- utilities for foreign declarations
658 -- supported calling conventions
660 data CallConv = CCall CCallConv -- ccall or stdcall
663 -- construct a foreign import declaration
667 -> (Located FastString, Located RdrName, LHsType RdrName)
668 -> P (HsDecl RdrName)
669 mkImport (CCall cconv) safety (entity, v, ty) = do
670 importSpec <- parseCImport entity cconv safety v
671 return (ForD (ForeignImport v ty importSpec False))
672 mkImport (DNCall ) _ (entity, v, ty) = do
673 spec <- parseDImport entity
674 return $ ForD (ForeignImport v ty (DNImport spec) False)
676 -- parse the entity string of a foreign import declaration for the `ccall' or
677 -- `stdcall' calling convention'
679 parseCImport :: Located FastString
684 parseCImport (L loc entity) cconv safety v
685 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
686 | entity == FSLIT ("dynamic") =
687 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
688 | entity == FSLIT ("wrapper") =
689 return $ CImport cconv safety nilFS nilFS CWrapper
690 | otherwise = parse0 (unpackFS entity)
692 -- using the static keyword?
693 parse0 (' ': rest) = parse0 rest
694 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
695 parse0 rest = parse1 rest
696 -- check for header file name
697 parse1 "" = parse4 "" nilFS False nilFS
698 parse1 (' ':rest) = parse1 rest
699 parse1 str@('&':_ ) = parse2 str nilFS
700 parse1 str@('[':_ ) = parse3 str nilFS False
702 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
703 | otherwise = parse4 str nilFS False nilFS
705 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
706 -- check for address operator (indicating a label import)
707 parse2 "" header = parse4 "" header False nilFS
708 parse2 (' ':rest) header = parse2 rest header
709 parse2 ('&':rest) header = parse3 rest header True
710 parse2 str@('[':_ ) header = parse3 str header False
711 parse2 str header = parse4 str header False nilFS
712 -- check for library object name
713 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
714 parse3 ('[':rest) header isLbl =
715 case break (== ']') rest of
716 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
717 _ -> parseError loc "Missing ']' in entity"
718 parse3 str header isLbl = parse4 str header isLbl nilFS
719 -- check for name of C function
720 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
721 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
722 parse4 str header isLbl lib
723 | all (== ' ') rest = build (mkFastString first) header isLbl lib
724 | otherwise = parseError loc "Malformed entity string"
726 (first, rest) = break (== ' ') str
728 build cid header False lib = return $
729 CImport cconv safety header lib (CFunction (StaticTarget cid))
730 build cid header True lib = return $
731 CImport cconv safety header lib (CLabel cid )
734 -- Unravel a dotnet spec string.
736 parseDImport :: Located FastString -> P DNCallSpec
737 parseDImport (L loc entity) = parse0 comps
739 comps = words (unpackFS entity)
743 | x == "static" = parse1 True xs
744 | otherwise = parse1 False (x:xs)
747 parse1 isStatic (x:xs)
748 | x == "method" = parse2 isStatic DNMethod xs
749 | x == "field" = parse2 isStatic DNField xs
750 | x == "ctor" = parse2 isStatic DNConstructor xs
751 parse1 isStatic xs = parse2 isStatic DNMethod xs
754 parse2 isStatic kind (('[':x):xs) =
757 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
758 parse2 isStatic kind xs = parse3 isStatic kind "" xs
760 parse3 isStatic kind assem [x] =
761 return (DNCallSpec isStatic kind assem x
762 -- these will be filled in once known.
763 (error "FFI-dotnet-args")
764 (error "FFI-dotnet-result"))
765 parse3 _ _ _ _ = d'oh
767 d'oh = parseError loc "Malformed entity string"
769 -- construct a foreign export declaration
772 -> (Located FastString, Located RdrName, LHsType RdrName)
773 -> P (HsDecl RdrName)
774 mkExport (CCall cconv) (L loc entity, v, ty) = return $
775 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
777 entity' | nullFastString entity = mkExtName (unLoc v)
779 mkExport DNCall (L loc entity, v, ty) =
780 parseError (getLoc v){-TODO: not quite right-}
781 "Foreign export is not yet supported for .NET"
783 -- Supplying the ext_name in a foreign decl is optional; if it
784 -- isn't there, the Haskell name is assumed. Note that no transformation
785 -- of the Haskell name is then performed, so if you foreign export (++),
786 -- it's external name will be "++". Too bad; it's important because we don't
787 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
788 -- (This is why we use occNameUserString.)
790 mkExtName :: RdrName -> CLabelString
791 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
795 -----------------------------------------------------------------------------
799 showRdrName :: RdrName -> String
800 showRdrName r = showSDoc (ppr r)
802 parseError :: SrcSpan -> String -> P a
803 parseError span s = failSpanMsgP span s