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, mkInlineSpec,
15 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
22 -- Stuff to do with Foreign declarations
24 mkImport, -- CallConv -> Safety
25 -- -> (FastString, RdrName, RdrNameHsType)
28 -- -> (FastString, RdrName, RdrNameHsType)
30 mkExtName, -- RdrName -> CLabelString
31 mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
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, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
39 checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
40 checkInstType, -- HsType -> P HsType
41 checkPattern, -- HsExp -> P HsPat
42 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
43 checkDo, -- [Stmt] -> P [Stmt]
44 checkMDo, -- [Stmt] -> P [Stmt]
45 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
46 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
47 parseError, -- String -> Pa
50 #include "HsVersions.h"
52 import HsSyn -- Lots of it
53 import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
54 isRdrDataCon, isUnqual, getRdrName, isQual,
56 import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
57 import Lexer ( P, failSpanMsgP, extension, bangPatEnabled )
58 import TysWiredIn ( unitTyCon )
59 import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
60 DNCallSpec(..), DNKind(..), CLabelString )
61 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
64 import OrdList ( OrdList, fromOL )
65 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
70 import List ( isSuffixOf, nubBy )
74 %************************************************************************
76 \subsection{A few functions over HsSyn at RdrName}
78 %************************************************************************
80 extractHsTyRdrNames finds the free variables of a HsType
81 It's used when making the for-alls explicit.
84 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
85 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
87 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
88 -- This one takes the context and tau-part of a
89 -- sigma type and returns their free type variables
90 extractHsRhoRdrTyVars ctxt ty
91 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
93 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
95 extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
96 extract_pred (HsIParam n ty) acc = extract_lty ty acc
98 extract_lty (L loc ty) acc
100 HsTyVar tv -> extract_tv loc tv acc
101 HsBangTy _ ty -> extract_lty ty acc
102 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
103 HsListTy ty -> extract_lty ty acc
104 HsPArrTy ty -> extract_lty ty acc
105 HsTupleTy _ tys -> foldr extract_lty acc tys
106 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
107 HsPredTy p -> extract_pred p acc
108 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
109 HsParTy ty -> extract_lty ty acc
111 HsSpliceTy _ -> acc -- Type splices mention no type variables
112 HsKindSig ty k -> extract_lty ty acc
113 HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc)
114 HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
115 extract_lctxt cx (extract_lty ty []))
117 locals = hsLTyVarNames tvs
119 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
120 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
123 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
124 -- Get the type variables out of the type patterns in a bunch of
125 -- possibly-generic bindings in a class declaration
126 extractGenericPatTyVars binds
127 = nubBy eqLocated (foldrBag get [] binds)
129 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
132 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
133 get_m other acc = acc
137 %************************************************************************
139 \subsection{Construction functions for Rdr stuff}
141 %************************************************************************
143 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
144 by deriving them from the name of the class. We fill in the names for the
145 tycon and datacon corresponding to the class, by deriving them from the
146 name of the class itself. This saves recording the names in the interface
147 file (which would be equally good).
149 Similarly for mkConDecl, mkClassOpSig and default-method names.
151 *** See "THE NAMING STORY" in HsDecls ****
154 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
155 = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
161 mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
162 = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
163 tcdTyVars = tyvars, tcdCons = data_cons,
164 tcdKindSig = ksig, tcdDerivs = maybe_deriv }
168 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
169 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
170 -- can't take an unboxed arg. But that is exactly what it will see when
171 -- we write "-3#". So we have to do the negation right now!
172 mkHsNegApp (L loc e) = f e
173 where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
174 f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
175 f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
176 f expr = NegApp (L loc e) noSyntaxExpr
179 %************************************************************************
181 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
183 %************************************************************************
185 Function definitions are restructured here. Each is assumed to be recursive
186 initially, and non recursive definitions are discovered by the dependency
191 -- | Groups together bindings for a single function
192 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
193 cvTopDecls decls = go (fromOL decls)
195 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
197 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
198 where (L l' b', ds') = getMonoBind (L l b) ds
199 go (d : ds) = d : go ds
201 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
203 = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
207 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
208 -> (Bag (LHsBind RdrName), [LSig RdrName])
209 -- Input decls contain just value bindings and signatures
210 cvBindsAndSigs fb = go (fromOL fb)
212 go [] = (emptyBag, [])
213 go (L l (SigD s) : ds) = (bs, L l s : ss)
214 where (bs,ss) = go ds
215 go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
216 where (b',ds') = getMonoBind (L l b) ds
219 -----------------------------------------------------------------------------
220 -- Group function bindings into equation groups
222 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
223 -> (LHsBind RdrName, [LHsDecl RdrName])
224 -- Suppose (b',ds') = getMonoBind b ds
225 -- ds is a list of parsed bindings
226 -- b is a MonoBinds that has just been read off the front
228 -- Then b' is the result of grouping more equations from ds that
229 -- belong with b into a single MonoBinds, and ds' is the depleted
230 -- list of parsed bindings.
232 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
234 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
235 fun_matches = MatchGroup mtchs1 _ })) binds
237 = go is_infix1 mtchs1 loc1 binds
239 go is_infix mtchs loc
240 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
241 fun_matches = MatchGroup mtchs2 _ })) : binds)
242 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
243 (combineSrcSpans loc loc2) binds
244 go is_infix mtchs loc binds
245 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)
246 -- Reverse the final matches, to get it back in the right order
248 getMonoBind bind binds = (bind, binds)
250 has_args ((L _ (Match args _ _)) : _) = not (null args)
251 -- Don't group together FunBinds if they have
252 -- no arguments. This is necessary now that variable bindings
253 -- with no arguments are now treated as FunBinds rather
254 -- than pattern bindings (tests/rename/should_fail/rnfail002).
258 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
259 findSplice ds = addl emptyRdrGroup ds
261 mkGroup :: [LHsDecl a] -> HsGroup a
262 mkGroup ds = addImpDecls emptyRdrGroup ds
264 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
265 -- The decls are imported, and should not have a splice
266 addImpDecls group decls = case addl group decls of
267 (group', Nothing) -> group'
268 other -> panic "addImpDecls"
270 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
271 -- This stuff reverses the declarations (again) but it doesn't matter
274 addl gp [] = (gp, Nothing)
275 addl gp (L l d : ds) = add gp l d ds
278 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
279 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
281 add gp l (SpliceD e) ds = (gp, Just (e, ds))
283 -- Class declarations: pull out the fixity signatures to the top
284 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
286 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
287 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
289 addl (gp { hs_tyclds = L l d : ts }) ds
291 -- Signatures: fixity sigs go a different place than all others
292 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
293 = addl (gp {hs_fixds = L l f : ts}) ds
294 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
295 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
297 -- Value declarations: use add_bind
298 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
299 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
301 -- The rest are routine
302 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
303 = addl (gp { hs_instds = L l d : ts }) ds
304 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
305 = addl (gp { hs_defds = L l d : ts }) ds
306 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
307 = addl (gp { hs_fords = L l d : ts }) ds
308 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
309 = addl (gp { hs_depds = L l d : ts }) ds
310 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
311 = addl (gp { hs_ruleds = L l d : ts }) ds
313 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
314 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
317 %************************************************************************
319 \subsection[PrefixToHS-utils]{Utilities for conversion}
321 %************************************************************************
325 -----------------------------------------------------------------------------
328 -- When parsing data declarations, we sometimes inadvertently parse
329 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
330 -- This function splits up the type application, adds any pending
331 -- arguments, and converts the type constructor back into a data constructor.
333 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
334 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
338 split (L _ (HsAppTy t u)) ts = split t (u : ts)
339 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
340 return (data_con, PrefixCon ts)
341 split (L l _) _ = parseError l "parse error in data/newtype declaration"
343 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
344 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
345 mkRecCon (L loc con) fields
346 = do data_con <- tyConToDataCon loc con
347 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
349 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
350 tyConToDataCon loc tc
351 | isTcOcc (rdrNameOcc tc)
352 = return (L loc (setRdrNameSpace tc srcDataName))
354 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
356 ----------------------------------------------------------------------------
357 -- Various Syntactic Checks
359 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
360 checkInstType (L l t)
362 HsForAllTy exp tvs ctxt ty -> do
363 dict_ty <- checkDictTy ty
364 return (L l (HsForAllTy exp tvs ctxt dict_ty))
366 HsParTy ty -> checkInstType ty
368 ty -> do dict_ty <- checkDictTy (L l ty)
369 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
371 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
375 -- Check that the name space is correct!
376 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
377 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
378 chk (L l (HsTyVar tv))
379 | isRdrTyVar tv = return (L l (UserTyVar tv))
381 = parseError l "Type found where type variable expected"
383 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
384 checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
387 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
388 -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
389 -- The header of a type or class decl should look like
390 -- (C a, D b) => T a b
394 checkTyClHdr (L l cxt) ty
395 = do (tc, tvs) <- gol ty []
397 return (L l cxt, tc, tvs)
399 gol (L l ty) acc = go l ty acc
401 go l (HsTyVar tc) acc
402 | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
404 go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
406 go l (HsParTy ty) acc = gol ty acc
407 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
408 go l other acc = parseError l "Malformed LHS to type of class declaration"
410 -- The predicates in a type or class decl must all
411 -- be HsClassPs. They need not all be type variables,
412 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
413 chk_pred (L l (HsClassP _ args)) = return ()
415 = parseError l "Malformed context in type or class declaration"
418 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
422 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
423 = do ctx <- mapM checkPred ts
426 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
429 check (HsTyVar t) -- Empty context shows up as a unit type ()
430 | t == getRdrName unitTyCon = return (L l [])
433 = do p <- checkPred (L l t)
437 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
438 -- Watch out.. in ...deriving( Show )... we use checkPred on
439 -- the list of partially applied predicates in the deriving,
440 -- so there can be zero args.
441 checkPred (L spn (HsPredTy (HsIParam n ty)))
442 = return (L spn (HsIParam n ty))
446 checkl (L l ty) args = check l ty args
448 check _loc (HsTyVar t) args | not (isRdrTyVar t)
449 = return (L spn (HsClassP t args))
450 check _loc (HsAppTy l r) args = checkl l (r:args)
451 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
452 check _loc (HsParTy t) args = checkl t args
453 check loc _ _ = parseError loc "malformed class assertion"
455 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
456 checkDictTy (L spn ty) = check ty []
458 check (HsTyVar t) args | not (isRdrTyVar t)
459 = return (L spn (HsPredTy (HsClassP t args)))
460 check (HsAppTy l r) args = check (unLoc l) (r:args)
461 check (HsParTy t) args = check (unLoc t) args
462 check _ _ = parseError spn "Malformed context in instance header"
464 ---------------------------------------------------------------------------
465 -- Checking statements in a do-expression
466 -- We parse do { e1 ; e2 ; }
467 -- as [ExprStmt e1, ExprStmt e2]
468 -- checkDo (a) checks that the last thing is an ExprStmt
469 -- (b) returns it separately
470 -- same comments apply for mdo as well
472 checkDo = checkDoMDo "a " "'do'"
473 checkMDo = checkDoMDo "an " "'mdo'"
475 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
476 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
477 checkDoMDo pre nm loc ss = do
480 check [L l (ExprStmt e _ _)] = return ([], e)
481 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
482 " construct must be an expression")
487 -- -------------------------------------------------------------------------
488 -- Checking Patterns.
490 -- We parse patterns as expressions and check for valid patterns below,
491 -- converting the expression into a pattern at the same time.
493 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
494 checkPattern e = checkLPat e
496 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
497 checkPatterns es = mapM checkPattern es
499 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
500 checkLPat e@(L l _) = checkPat l e []
502 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
503 checkPat loc (L l (HsVar c)) args
504 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
505 checkPat loc e args -- OK to let this happen even if bang-patterns
506 -- are not enabled, because there is no valid
507 -- non-bang-pattern parse of (C ! e)
508 | Just (e', args') <- splitBang e
509 = do { args'' <- checkPatterns args'
510 ; checkPat loc e' (args'' ++ args) }
511 checkPat loc (L _ (HsApp f x)) args
512 = do { x <- checkLPat x; checkPat loc f (x:args) }
513 checkPat loc (L _ e) []
514 = do { p <- checkAPat loc e; return (L loc p) }
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 (mkNPat pos_lit Nothing)
530 NegApp (L _ (HsOverLit pos_lit)) _
531 -> return (mkNPat pos_lit (Just noSyntaxExpr))
533 SectionR (L _ (HsVar bang)) e
534 | bang == bang_RDR -> checkLPat e >>= (return . BangPat)
535 ELazyPat e -> checkLPat e >>= (return . LazyPat)
536 EAsPat n e -> checkLPat e >>= (return . AsPat n)
537 ExprWithTySig e t -> checkLPat e >>= \e ->
538 -- Pattern signatures are parsed as sigtypes,
539 -- but they aren't explicit forall points. Hence
540 -- we have to remove the implicit forall here.
542 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
545 return (SigPatIn e t')
548 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
549 (L _ (HsOverLit lit@(HsIntegral _ _)))
551 -> return (mkNPlusKPat (L nloc n) lit)
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 placeHolderType)
569 RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
570 return (ConPatIn c (RecCon fs))
572 HsType ty -> return (TypePat ty)
575 plus_RDR, bang_RDR :: RdrName
576 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
577 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
579 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
580 checkPatField (n,e) = do
584 patFail loc = parseError loc "Parse error in pattern"
587 ---------------------------------------------------------------------------
588 -- Check Equation Syntax
590 checkValDef :: LHsExpr RdrName
591 -> Maybe (LHsType RdrName)
592 -> Located (GRHSs RdrName)
593 -> P (HsBind RdrName)
595 checkValDef lhs opt_sig grhss
596 = do { mb_fun <- isFunLhs lhs
598 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
599 fun is_infix pats opt_sig grhss
600 Nothing -> checkPatBind lhs grhss }
602 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
604 = parseError (getLoc fun) ("Qualified name in function definition: " ++
605 showRdrName (unLoc fun))
607 = do ps <- checkPatterns pats
608 let match_span = combineSrcSpans lhs_loc rhs_span
609 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
610 -- The span of the match covers the entire equation.
611 -- That isn't quite right, but it'll do for now.
613 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
614 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
615 makeFunBind fn is_infix ms
616 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
617 fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
619 checkPatBind lhs (L _ grhss)
620 = do { lhs <- checkPattern lhs
621 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
627 checkValSig (L l (HsVar v)) ty
628 | isUnqual v && not (isDataOcc (rdrNameOcc v))
629 = return (TypeSig (L l v) ty)
630 checkValSig (L l other) ty
631 = parseError l "Invalid type signature"
633 mkGadtDecl :: Located RdrName
634 -> LHsType RdrName -- assuming HsType
636 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
637 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
639 mk_gadt_con name qvars cxt ty
640 = ConDecl { con_name = name
641 , con_explicit = Implicit
644 , con_details = PrefixCon []
645 , con_res = ResTyGADT ty }
646 -- NB: we put the whole constr type into the ResTyGADT for now;
647 -- the renamer will unravel it once it has sorted out
650 -- A variable binding is parsed as a FunBind.
653 -- The parser left-associates, so there should
654 -- not be any OpApps inside the e's
655 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
656 -- Splits (f ! g a b) into (f, [(! g), a, g])
657 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
658 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
660 (arg1,argns) = split_bang r_arg []
661 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
662 split_bang e es = (e,es)
663 splitBang other = Nothing
665 isFunLhs :: LHsExpr RdrName
666 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
667 -- Just (fun, is_infix, arg_pats) if e is a function LHS
670 go (L loc (HsVar f)) es
671 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
672 go (L _ (HsApp f e)) es = go f (e:es)
673 go (L _ (HsPar e)) es@(_:_) = go e es
675 -- For infix function defns, there should be only one infix *function*
676 -- (though there may be infix *datacons* involved too). So we don't
677 -- need fixity info to figure out which function is being defined.
678 -- a `K1` b `op` c `K2` d
680 -- (a `K1` b) `op` (c `K2` d)
681 -- The renamer checks later that the precedences would yield such a parse.
683 -- There is a complication to deal with bang patterns.
685 -- ToDo: what about this?
686 -- x + 1 `op` y = ...
688 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
689 | Just (e',es') <- splitBang e
690 = do { bang_on <- extension bangPatEnabled
691 ; if bang_on then go e' (es' ++ es)
692 else return (Just (L loc' op, True, (l:r:es))) }
693 -- No bangs; behave just like the next case
694 | not (isRdrDataCon op) -- We have found the function!
695 = return (Just (L loc' op, True, (l:r:es)))
696 | otherwise -- Infix data con; keep going
697 = do { mb_l <- go l es
699 Just (op', True, j : k : es')
700 -> return (Just (op', True, j : op_app : es'))
702 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
703 _ -> return Nothing }
704 go _ _ = return Nothing
706 ---------------------------------------------------------------------------
707 -- Miscellaneous utilities
709 checkPrecP :: Located Int -> P Int
711 | 0 <= i && i <= maxPrecedence = return i
712 | otherwise = parseError l "Precedence out of range"
717 -> HsRecordBinds RdrName
718 -> P (HsExpr RdrName)
720 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
721 = return (RecordCon (L l c) noPostTcExpr fs)
722 mkRecConstrOrUpdate exp loc fs@(_:_)
723 = return (RecordUpd exp fs placeHolderType placeHolderType)
724 mkRecConstrOrUpdate _ loc []
725 = parseError loc "Empty record update"
727 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
728 -- The Maybe is becuase the user can omit the activation spec (and usually does)
729 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
730 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
731 mkInlineSpec (Just act) inl = Inline act inl
734 -----------------------------------------------------------------------------
735 -- utilities for foreign declarations
737 -- supported calling conventions
739 data CallConv = CCall CCallConv -- ccall or stdcall
742 -- construct a foreign import declaration
746 -> (Located FastString, Located RdrName, LHsType RdrName)
747 -> P (HsDecl RdrName)
748 mkImport (CCall cconv) safety (entity, v, ty) = do
749 importSpec <- parseCImport entity cconv safety v
750 return (ForD (ForeignImport v ty importSpec))
751 mkImport (DNCall ) _ (entity, v, ty) = do
752 spec <- parseDImport entity
753 return $ ForD (ForeignImport v ty (DNImport spec))
755 -- parse the entity string of a foreign import declaration for the `ccall' or
756 -- `stdcall' calling convention'
758 parseCImport :: Located FastString
763 parseCImport (L loc entity) cconv safety v
764 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
765 | entity == FSLIT ("dynamic") =
766 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
767 | entity == FSLIT ("wrapper") =
768 return $ CImport cconv safety nilFS nilFS CWrapper
769 | otherwise = parse0 (unpackFS entity)
771 -- using the static keyword?
772 parse0 (' ': rest) = parse0 rest
773 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
774 parse0 rest = parse1 rest
775 -- check for header file name
776 parse1 "" = parse4 "" nilFS False nilFS
777 parse1 (' ':rest) = parse1 rest
778 parse1 str@('&':_ ) = parse2 str nilFS
779 parse1 str@('[':_ ) = parse3 str nilFS False
781 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
782 | otherwise = parse4 str nilFS False nilFS
784 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
785 -- check for address operator (indicating a label import)
786 parse2 "" header = parse4 "" header False nilFS
787 parse2 (' ':rest) header = parse2 rest header
788 parse2 ('&':rest) header = parse3 rest header True
789 parse2 str@('[':_ ) header = parse3 str header False
790 parse2 str header = parse4 str header False nilFS
791 -- check for library object name
792 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
793 parse3 ('[':rest) header isLbl =
794 case break (== ']') rest of
795 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
796 _ -> parseError loc "Missing ']' in entity"
797 parse3 str header isLbl = parse4 str header isLbl nilFS
798 -- check for name of C function
799 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
800 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
801 parse4 str header isLbl lib
802 | all (== ' ') rest = build (mkFastString first) header isLbl lib
803 | otherwise = parseError loc "Malformed entity string"
805 (first, rest) = break (== ' ') str
807 build cid header False lib = return $
808 CImport cconv safety header lib (CFunction (StaticTarget cid))
809 build cid header True lib = return $
810 CImport cconv safety header lib (CLabel cid )
813 -- Unravel a dotnet spec string.
815 parseDImport :: Located FastString -> P DNCallSpec
816 parseDImport (L loc entity) = parse0 comps
818 comps = words (unpackFS entity)
822 | x == "static" = parse1 True xs
823 | otherwise = parse1 False (x:xs)
826 parse1 isStatic (x:xs)
827 | x == "method" = parse2 isStatic DNMethod xs
828 | x == "field" = parse2 isStatic DNField xs
829 | x == "ctor" = parse2 isStatic DNConstructor xs
830 parse1 isStatic xs = parse2 isStatic DNMethod xs
833 parse2 isStatic kind (('[':x):xs) =
836 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
837 parse2 isStatic kind xs = parse3 isStatic kind "" xs
839 parse3 isStatic kind assem [x] =
840 return (DNCallSpec isStatic kind assem x
841 -- these will be filled in once known.
842 (error "FFI-dotnet-args")
843 (error "FFI-dotnet-result"))
844 parse3 _ _ _ _ = d'oh
846 d'oh = parseError loc "Malformed entity string"
848 -- construct a foreign export declaration
851 -> (Located FastString, Located RdrName, LHsType RdrName)
852 -> P (HsDecl RdrName)
853 mkExport (CCall cconv) (L loc entity, v, ty) = return $
854 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
856 entity' | nullFS entity = mkExtName (unLoc v)
858 mkExport DNCall (L loc entity, v, ty) =
859 parseError (getLoc v){-TODO: not quite right-}
860 "Foreign export is not yet supported for .NET"
862 -- Supplying the ext_name in a foreign decl is optional; if it
863 -- isn't there, the Haskell name is assumed. Note that no transformation
864 -- of the Haskell name is then performed, so if you foreign export (++),
865 -- it's external name will be "++". Too bad; it's important because we don't
866 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
868 mkExtName :: RdrName -> CLabelString
869 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
873 -----------------------------------------------------------------------------
877 showRdrName :: RdrName -> String
878 showRdrName r = showSDoc (ppr r)
880 parseError :: SrcSpan -> String -> P a
881 parseError span s = failSpanMsgP span s