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 *reversed* 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 loc bind@(FunBind { fun_id = L _ f, fun_matches = MatchGroup mtchs _ })) binds
238 go mtchs1 loc1 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_matches = MatchGroup mtchs2 _ })) : binds)
239 | f == f2 = go (mtchs2++mtchs1) loc binds
240 where loc = combineSrcSpans loc1 loc2
242 = (L loc (bind { fun_matches = mkMatchGroup (reverse mtchs1) }), binds)
243 -- Reverse the final matches, to get it back in the right order
245 getMonoBind bind binds = (bind, binds)
247 has_args ((L _ (Match args _ _)) : _) = not (null args)
248 -- Don't group together FunBinds if they have
249 -- no arguments. This is necessary now that variable bindings
250 -- with no arguments are now treated as FunBinds rather
251 -- than pattern bindings (tests/rename/should_fail/rnfail002).
255 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
256 findSplice ds = addl emptyRdrGroup ds
258 mkGroup :: [LHsDecl a] -> HsGroup a
259 mkGroup ds = addImpDecls emptyRdrGroup ds
261 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
262 -- The decls are imported, and should not have a splice
263 addImpDecls group decls = case addl group decls of
264 (group', Nothing) -> group'
265 other -> panic "addImpDecls"
267 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
268 -- This stuff reverses the declarations (again) but it doesn't matter
271 addl gp [] = (gp, Nothing)
272 addl gp (L l d : ds) = add gp l d ds
275 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
276 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
278 add gp l (SpliceD e) ds = (gp, Just (e, ds))
280 -- Class declarations: pull out the fixity signatures to the top
281 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
283 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
284 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
286 addl (gp { hs_tyclds = L l d : ts }) ds
288 -- Signatures: fixity sigs go a different place than all others
289 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
290 = addl (gp {hs_fixds = L l f : ts}) ds
291 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
292 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
294 -- Value declarations: use add_bind
295 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
296 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
298 -- The rest are routine
299 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
300 = addl (gp { hs_instds = L l d : ts }) ds
301 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
302 = addl (gp { hs_defds = L l d : ts }) ds
303 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
304 = addl (gp { hs_fords = L l d : ts }) ds
305 add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
306 = addl (gp { hs_depds = L l d : ts }) ds
307 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
308 = addl (gp { hs_ruleds = L l d : ts }) ds
310 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
311 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
314 %************************************************************************
316 \subsection[PrefixToHS-utils]{Utilities for conversion}
318 %************************************************************************
322 -----------------------------------------------------------------------------
325 -- When parsing data declarations, we sometimes inadvertently parse
326 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
327 -- This function splits up the type application, adds any pending
328 -- arguments, and converts the type constructor back into a data constructor.
330 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
331 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
335 split (L _ (HsAppTy t u)) ts = split t (u : ts)
336 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
337 return (data_con, PrefixCon ts)
338 split (L l _) _ = parseError l "parse error in data/newtype declaration"
340 mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
341 -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
342 mkRecCon (L loc con) fields
343 = do data_con <- tyConToDataCon loc con
344 return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
346 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
347 tyConToDataCon loc tc
348 | isTcOcc (rdrNameOcc tc)
349 = return (L loc (setRdrNameSpace tc srcDataName))
351 = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
353 ----------------------------------------------------------------------------
354 -- Various Syntactic Checks
356 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
357 checkInstType (L l t)
359 HsForAllTy exp tvs ctxt ty -> do
360 dict_ty <- checkDictTy ty
361 return (L l (HsForAllTy exp tvs ctxt dict_ty))
363 HsParTy ty -> checkInstType ty
365 ty -> do dict_ty <- checkDictTy (L l ty)
366 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
368 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
372 -- Check that the name space is correct!
373 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
374 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
375 chk (L l (HsTyVar tv))
376 | isRdrTyVar tv = return (L l (UserTyVar tv))
378 = parseError l "Type found where type variable expected"
380 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
381 checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
384 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
385 -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
386 -- The header of a type or class decl should look like
387 -- (C a, D b) => T a b
391 checkTyClHdr (L l cxt) ty
392 = do (tc, tvs) <- gol ty []
394 return (L l cxt, tc, tvs)
396 gol (L l ty) acc = go l ty acc
398 go l (HsTyVar tc) acc
399 | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
401 go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
403 go l (HsParTy ty) acc = gol ty acc
404 go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
405 go l other acc = parseError l "Malformed LHS to type of class declaration"
407 -- The predicates in a type or class decl must all
408 -- be HsClassPs. They need not all be type variables,
409 -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
410 chk_pred (L l (HsClassP _ args)) = return ()
412 = parseError l "Malformed context in type or class declaration"
415 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
419 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
420 = do ctx <- mapM checkPred ts
423 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
426 check (HsTyVar t) -- Empty context shows up as a unit type ()
427 | t == getRdrName unitTyCon = return (L l [])
430 = do p <- checkPred (L l t)
434 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
435 -- Watch out.. in ...deriving( Show )... we use checkPred on
436 -- the list of partially applied predicates in the deriving,
437 -- so there can be zero args.
438 checkPred (L spn (HsPredTy (HsIParam n ty)))
439 = return (L spn (HsIParam n ty))
443 checkl (L l ty) args = check l ty args
445 check _loc (HsTyVar t) args | not (isRdrTyVar t)
446 = return (L spn (HsClassP t args))
447 check _loc (HsAppTy l r) args = checkl l (r:args)
448 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
449 check _loc (HsParTy t) args = checkl t args
450 check loc _ _ = parseError loc "malformed class assertion"
452 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
453 checkDictTy (L spn ty) = check ty []
455 check (HsTyVar t) args | not (isRdrTyVar t)
456 = return (L spn (HsPredTy (HsClassP t args)))
457 check (HsAppTy l r) args = check (unLoc l) (r:args)
458 check (HsParTy t) args = check (unLoc t) args
459 check _ _ = parseError spn "Malformed context in instance header"
461 ---------------------------------------------------------------------------
462 -- Checking statements in a do-expression
463 -- We parse do { e1 ; e2 ; }
464 -- as [ExprStmt e1, ExprStmt e2]
465 -- checkDo (a) checks that the last thing is an ExprStmt
466 -- (b) returns it separately
467 -- same comments apply for mdo as well
469 checkDo = checkDoMDo "a " "'do'"
470 checkMDo = checkDoMDo "an " "'mdo'"
472 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
473 checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
474 checkDoMDo pre nm loc ss = do
477 check [L l (ExprStmt e _ _)] = return ([], e)
478 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
479 " construct must be an expression")
484 -- -------------------------------------------------------------------------
485 -- Checking Patterns.
487 -- We parse patterns as expressions and check for valid patterns below,
488 -- converting the expression into a pattern at the same time.
490 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
491 checkPattern e = checkLPat e
493 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
494 checkPatterns es = mapM checkPattern es
496 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
497 checkLPat e@(L l _) = checkPat l e []
499 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
500 checkPat loc (L l (HsVar c)) args
501 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
502 checkPat loc e args -- OK to let this happen even if bang-patterns
503 -- are not enabled, because there is no valid
504 -- non-bang-pattern parse of (C ! e)
505 | Just (e', args') <- splitBang e
506 = do { args'' <- checkPatterns args'
507 ; checkPat loc e' (args'' ++ args) }
508 checkPat loc (L _ (HsApp f x)) args
509 = do { x <- checkLPat x; checkPat loc f (x:args) }
510 checkPat loc (L _ e) []
511 = do { p <- checkAPat loc e; return (L loc p) }
512 checkPat loc pat _some_args
515 checkAPat loc e = case e of
516 EWildPat -> return (WildPat placeHolderType)
517 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
519 | otherwise -> return (VarPat x)
520 HsLit l -> return (LitPat l)
522 -- Overloaded numeric patterns (e.g. f 0 x = x)
523 -- Negation is recorded separately, so that the literal is zero or +ve
524 -- NB. Negative *primitive* literals are already handled by
525 -- RdrHsSyn.mkHsNegApp
526 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
527 NegApp (L _ (HsOverLit pos_lit)) _
528 -> return (mkNPat pos_lit (Just noSyntaxExpr))
530 SectionR (L _ (HsVar bang)) e
531 | bang == bang_RDR -> checkLPat e >>= (return . BangPat)
532 ELazyPat e -> checkLPat e >>= (return . LazyPat)
533 EAsPat n e -> checkLPat e >>= (return . AsPat n)
534 ExprWithTySig e t -> checkLPat e >>= \e ->
535 -- Pattern signatures are parsed as sigtypes,
536 -- but they aren't explicit forall points. Hence
537 -- we have to remove the implicit forall here.
539 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
542 return (SigPatIn e t')
545 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
546 (L _ (HsOverLit lit@(HsIntegral _ _)))
548 -> return (mkNPlusKPat (L nloc n) lit)
550 OpApp l op fix r -> checkLPat l >>= \l ->
551 checkLPat r >>= \r ->
553 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
554 -> return (ConPatIn (L cl c) (InfixCon l r))
557 HsPar e -> checkLPat e >>= (return . ParPat)
558 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
559 return (ListPat ps placeHolderType)
560 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
561 return (PArrPat ps placeHolderType)
563 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
564 return (TuplePat ps b placeHolderType)
566 RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
567 return (ConPatIn c (RecCon fs))
569 HsType ty -> return (TypePat ty)
572 plus_RDR, bang_RDR :: RdrName
573 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
574 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
576 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
577 checkPatField (n,e) = do
581 patFail loc = parseError loc "Parse error in pattern"
584 ---------------------------------------------------------------------------
585 -- Check Equation Syntax
587 checkValDef :: LHsExpr RdrName
588 -> Maybe (LHsType RdrName)
589 -> Located (GRHSs RdrName)
590 -> P (HsBind RdrName)
592 checkValDef lhs opt_sig grhss
593 = do { mb_fun <- isFunLhs lhs
595 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
596 fun is_infix pats opt_sig grhss
597 Nothing -> checkPatBind lhs grhss }
599 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
601 = parseError (getLoc fun) ("Qualified name in function definition: " ++
602 showRdrName (unLoc fun))
604 = do ps <- checkPatterns pats
605 let match_span = combineSrcSpans lhs_loc rhs_span
606 matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)]
607 return (FunBind { fun_id = fun, fun_infix = is_infix, fun_matches = matches,
608 fun_co_fn = idCoercion, bind_fvs = placeHolderNames })
609 -- The span of the match covers the entire equation.
610 -- That isn't quite right, but it'll do for now.
612 checkPatBind lhs (L _ grhss)
613 = do { lhs <- checkPattern lhs
614 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
620 checkValSig (L l (HsVar v)) ty
621 | isUnqual v && not (isDataOcc (rdrNameOcc v))
622 = return (TypeSig (L l v) ty)
623 checkValSig (L l other) ty
624 = parseError l "Invalid type signature"
628 -> LHsType RdrName -- assuming HsType
630 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl
632 , con_explicit = Implicit
635 , con_details = PrefixCon args
636 , con_res = ResTyGADT res
639 (args, res) = splitHsFunType ty
640 mkGadtDecl name ty = ConDecl
642 , con_explicit = Implicit
645 , con_details = PrefixCon args
646 , con_res = ResTyGADT res
649 (args, res) = splitHsFunType ty
651 -- A variable binding is parsed as a FunBind.
654 -- The parser left-associates, so there should
655 -- not be any OpApps inside the e's
656 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
657 -- Splits (f ! g a b) into (f, [(! g), a, g])
658 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
659 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
661 (arg1,argns) = split_bang r_arg []
662 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
663 split_bang e es = (e,es)
664 splitBang other = Nothing
666 isFunLhs :: LHsExpr RdrName
667 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
668 -- Just (fun, is_infix, arg_pats) if e is a function LHS
671 go (L loc (HsVar f)) es
672 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
673 go (L _ (HsApp f e)) es = go f (e:es)
674 go (L _ (HsPar e)) es@(_:_) = go e es
675 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
676 | Just (e',es') <- splitBang e
677 = do { bang_on <- extension bangPatEnabled
678 ; if bang_on then go e' (es' ++ es)
679 else return (Just (L loc' op, True, (l:r:es))) }
680 -- No bangs; behave just like the next case
681 | not (isRdrDataCon op)
682 = return (Just (L loc' op, True, (l:r:es)))
684 = do { mb_l <- go l es
686 Just (op', True, j : k : es')
687 -> return (Just (op', True, j : op_app : es'))
689 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
690 _ -> return Nothing }
691 go _ _ = return Nothing
693 ---------------------------------------------------------------------------
694 -- Miscellaneous utilities
696 checkPrecP :: Located Int -> P Int
698 | 0 <= i && i <= maxPrecedence = return i
699 | otherwise = parseError l "Precedence out of range"
704 -> HsRecordBinds RdrName
705 -> P (HsExpr RdrName)
707 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
708 = return (RecordCon (L l c) noPostTcExpr fs)
709 mkRecConstrOrUpdate exp loc fs@(_:_)
710 = return (RecordUpd exp fs placeHolderType placeHolderType)
711 mkRecConstrOrUpdate _ loc []
712 = parseError loc "Empty record update"
714 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
715 -- The Maybe is becuase the user can omit the activation spec (and usually does)
716 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
717 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
718 mkInlineSpec (Just act) inl = Inline act inl
721 -----------------------------------------------------------------------------
722 -- utilities for foreign declarations
724 -- supported calling conventions
726 data CallConv = CCall CCallConv -- ccall or stdcall
729 -- construct a foreign import declaration
733 -> (Located FastString, Located RdrName, LHsType RdrName)
734 -> P (HsDecl RdrName)
735 mkImport (CCall cconv) safety (entity, v, ty) = do
736 importSpec <- parseCImport entity cconv safety v
737 return (ForD (ForeignImport v ty importSpec False))
738 mkImport (DNCall ) _ (entity, v, ty) = do
739 spec <- parseDImport entity
740 return $ ForD (ForeignImport v ty (DNImport spec) False)
742 -- parse the entity string of a foreign import declaration for the `ccall' or
743 -- `stdcall' calling convention'
745 parseCImport :: Located FastString
750 parseCImport (L loc entity) cconv safety v
751 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
752 | entity == FSLIT ("dynamic") =
753 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
754 | entity == FSLIT ("wrapper") =
755 return $ CImport cconv safety nilFS nilFS CWrapper
756 | otherwise = parse0 (unpackFS entity)
758 -- using the static keyword?
759 parse0 (' ': rest) = parse0 rest
760 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
761 parse0 rest = parse1 rest
762 -- check for header file name
763 parse1 "" = parse4 "" nilFS False nilFS
764 parse1 (' ':rest) = parse1 rest
765 parse1 str@('&':_ ) = parse2 str nilFS
766 parse1 str@('[':_ ) = parse3 str nilFS False
768 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
769 | otherwise = parse4 str nilFS False nilFS
771 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
772 -- check for address operator (indicating a label import)
773 parse2 "" header = parse4 "" header False nilFS
774 parse2 (' ':rest) header = parse2 rest header
775 parse2 ('&':rest) header = parse3 rest header True
776 parse2 str@('[':_ ) header = parse3 str header False
777 parse2 str header = parse4 str header False nilFS
778 -- check for library object name
779 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
780 parse3 ('[':rest) header isLbl =
781 case break (== ']') rest of
782 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
783 _ -> parseError loc "Missing ']' in entity"
784 parse3 str header isLbl = parse4 str header isLbl nilFS
785 -- check for name of C function
786 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
787 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
788 parse4 str header isLbl lib
789 | all (== ' ') rest = build (mkFastString first) header isLbl lib
790 | otherwise = parseError loc "Malformed entity string"
792 (first, rest) = break (== ' ') str
794 build cid header False lib = return $
795 CImport cconv safety header lib (CFunction (StaticTarget cid))
796 build cid header True lib = return $
797 CImport cconv safety header lib (CLabel cid )
800 -- Unravel a dotnet spec string.
802 parseDImport :: Located FastString -> P DNCallSpec
803 parseDImport (L loc entity) = parse0 comps
805 comps = words (unpackFS entity)
809 | x == "static" = parse1 True xs
810 | otherwise = parse1 False (x:xs)
813 parse1 isStatic (x:xs)
814 | x == "method" = parse2 isStatic DNMethod xs
815 | x == "field" = parse2 isStatic DNField xs
816 | x == "ctor" = parse2 isStatic DNConstructor xs
817 parse1 isStatic xs = parse2 isStatic DNMethod xs
820 parse2 isStatic kind (('[':x):xs) =
823 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
824 parse2 isStatic kind xs = parse3 isStatic kind "" xs
826 parse3 isStatic kind assem [x] =
827 return (DNCallSpec isStatic kind assem x
828 -- these will be filled in once known.
829 (error "FFI-dotnet-args")
830 (error "FFI-dotnet-result"))
831 parse3 _ _ _ _ = d'oh
833 d'oh = parseError loc "Malformed entity string"
835 -- construct a foreign export declaration
838 -> (Located FastString, Located RdrName, LHsType RdrName)
839 -> P (HsDecl RdrName)
840 mkExport (CCall cconv) (L loc entity, v, ty) = return $
841 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
843 entity' | nullFS entity = mkExtName (unLoc v)
845 mkExport DNCall (L loc entity, v, ty) =
846 parseError (getLoc v){-TODO: not quite right-}
847 "Foreign export is not yet supported for .NET"
849 -- Supplying the ext_name in a foreign decl is optional; if it
850 -- isn't there, the Haskell name is assumed. Note that no transformation
851 -- of the Haskell name is then performed, so if you foreign export (++),
852 -- it's external name will be "++". Too bad; it's important because we don't
853 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
855 mkExtName :: RdrName -> CLabelString
856 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
860 -----------------------------------------------------------------------------
864 showRdrName :: RdrName -> String
865 showRdrName r = showSDoc (ppr r)
867 parseError :: SrcSpan -> String -> P a
868 parseError span s = failSpanMsgP span s