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 -- (! x)
535 -> do { bang_on <- extension bangPatEnabled
536 ; if bang_on then checkLPat e >>= (return . BangPat)
537 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
539 ELazyPat e -> checkLPat e >>= (return . LazyPat)
540 EAsPat n e -> checkLPat e >>= (return . AsPat n)
541 ExprWithTySig e t -> checkLPat e >>= \e ->
542 -- Pattern signatures are parsed as sigtypes,
543 -- but they aren't explicit forall points. Hence
544 -- we have to remove the implicit forall here.
546 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
549 return (SigPatIn e t')
552 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
553 (L _ (HsOverLit lit@(HsIntegral _ _)))
555 -> return (mkNPlusKPat (L nloc n) lit)
557 OpApp l op fix r -> checkLPat l >>= \l ->
558 checkLPat r >>= \r ->
560 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
561 -> return (ConPatIn (L cl c) (InfixCon l r))
564 HsPar e -> checkLPat e >>= (return . ParPat)
565 ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
566 return (ListPat ps placeHolderType)
567 ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
568 return (PArrPat ps placeHolderType)
570 ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
571 return (TuplePat ps b placeHolderType)
573 RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
574 return (ConPatIn c (RecCon fs))
576 HsType ty -> return (TypePat ty)
579 plus_RDR, bang_RDR :: RdrName
580 plus_RDR = mkUnqual varName FSLIT("+") -- Hack
581 bang_RDR = mkUnqual varName FSLIT("!") -- Hack
583 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
584 checkPatField (n,e) = do
588 patFail loc = parseError loc "Parse error in pattern"
591 ---------------------------------------------------------------------------
592 -- Check Equation Syntax
594 checkValDef :: LHsExpr RdrName
595 -> Maybe (LHsType RdrName)
596 -> Located (GRHSs RdrName)
597 -> P (HsBind RdrName)
599 checkValDef lhs opt_sig grhss
600 = do { mb_fun <- isFunLhs lhs
602 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
603 fun is_infix pats opt_sig grhss
604 Nothing -> checkPatBind lhs grhss }
606 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
608 = parseError (getLoc fun) ("Qualified name in function definition: " ++
609 showRdrName (unLoc fun))
611 = do ps <- checkPatterns pats
612 let match_span = combineSrcSpans lhs_loc rhs_span
613 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
614 -- The span of the match covers the entire equation.
615 -- That isn't quite right, but it'll do for now.
617 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
618 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
619 makeFunBind fn is_infix ms
620 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
621 fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
623 checkPatBind lhs (L _ grhss)
624 = do { lhs <- checkPattern lhs
625 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
631 checkValSig (L l (HsVar v)) ty
632 | isUnqual v && not (isDataOcc (rdrNameOcc v))
633 = return (TypeSig (L l v) ty)
634 checkValSig (L l other) ty
635 = parseError l "Invalid type signature"
637 mkGadtDecl :: Located RdrName
638 -> LHsType RdrName -- assuming HsType
640 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
641 mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
643 mk_gadt_con name qvars cxt ty
644 = ConDecl { con_name = name
645 , con_explicit = Implicit
648 , con_details = PrefixCon []
649 , con_res = ResTyGADT ty }
650 -- NB: we put the whole constr type into the ResTyGADT for now;
651 -- the renamer will unravel it once it has sorted out
654 -- A variable binding is parsed as a FunBind.
657 -- The parser left-associates, so there should
658 -- not be any OpApps inside the e's
659 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
660 -- Splits (f ! g a b) into (f, [(! g), a, g])
661 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
662 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
664 (arg1,argns) = split_bang r_arg []
665 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
666 split_bang e es = (e,es)
667 splitBang other = Nothing
669 isFunLhs :: LHsExpr RdrName
670 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
671 -- Just (fun, is_infix, arg_pats) if e is a function LHS
674 go (L loc (HsVar f)) es
675 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
676 go (L _ (HsApp f e)) es = go f (e:es)
677 go (L _ (HsPar e)) es@(_:_) = go e es
679 -- For infix function defns, there should be only one infix *function*
680 -- (though there may be infix *datacons* involved too). So we don't
681 -- need fixity info to figure out which function is being defined.
682 -- a `K1` b `op` c `K2` d
684 -- (a `K1` b) `op` (c `K2` d)
685 -- The renamer checks later that the precedences would yield such a parse.
687 -- There is a complication to deal with bang patterns.
689 -- ToDo: what about this?
690 -- x + 1 `op` y = ...
692 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
693 | Just (e',es') <- splitBang e
694 = do { bang_on <- extension bangPatEnabled
695 ; if bang_on then go e' (es' ++ es)
696 else return (Just (L loc' op, True, (l:r:es))) }
697 -- No bangs; behave just like the next case
698 | not (isRdrDataCon op) -- We have found the function!
699 = return (Just (L loc' op, True, (l:r:es)))
700 | otherwise -- Infix data con; keep going
701 = do { mb_l <- go l es
703 Just (op', True, j : k : es')
704 -> return (Just (op', True, j : op_app : es'))
706 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
707 _ -> return Nothing }
708 go _ _ = return Nothing
710 ---------------------------------------------------------------------------
711 -- Miscellaneous utilities
713 checkPrecP :: Located Int -> P Int
715 | 0 <= i && i <= maxPrecedence = return i
716 | otherwise = parseError l "Precedence out of range"
721 -> HsRecordBinds RdrName
722 -> P (HsExpr RdrName)
724 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
725 = return (RecordCon (L l c) noPostTcExpr fs)
726 mkRecConstrOrUpdate exp loc fs@(_:_)
727 = return (RecordUpd exp fs placeHolderType placeHolderType)
728 mkRecConstrOrUpdate _ loc []
729 = parseError loc "Empty record update"
731 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
732 -- The Maybe is becuase the user can omit the activation spec (and usually does)
733 mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
734 mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
735 mkInlineSpec (Just act) inl = Inline act inl
738 -----------------------------------------------------------------------------
739 -- utilities for foreign declarations
741 -- supported calling conventions
743 data CallConv = CCall CCallConv -- ccall or stdcall
746 -- construct a foreign import declaration
750 -> (Located FastString, Located RdrName, LHsType RdrName)
751 -> P (HsDecl RdrName)
752 mkImport (CCall cconv) safety (entity, v, ty) = do
753 importSpec <- parseCImport entity cconv safety v
754 return (ForD (ForeignImport v ty importSpec))
755 mkImport (DNCall ) _ (entity, v, ty) = do
756 spec <- parseDImport entity
757 return $ ForD (ForeignImport v ty (DNImport spec))
759 -- parse the entity string of a foreign import declaration for the `ccall' or
760 -- `stdcall' calling convention'
762 parseCImport :: Located FastString
767 parseCImport (L loc entity) cconv safety v
768 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
769 | entity == FSLIT ("dynamic") =
770 return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
771 | entity == FSLIT ("wrapper") =
772 return $ CImport cconv safety nilFS nilFS CWrapper
773 | otherwise = parse0 (unpackFS entity)
775 -- using the static keyword?
776 parse0 (' ': rest) = parse0 rest
777 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
778 parse0 rest = parse1 rest
779 -- check for header file name
780 parse1 "" = parse4 "" nilFS False nilFS
781 parse1 (' ':rest) = parse1 rest
782 parse1 str@('&':_ ) = parse2 str nilFS
783 parse1 str@('[':_ ) = parse3 str nilFS False
785 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
786 | otherwise = parse4 str nilFS False nilFS
788 (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
789 -- check for address operator (indicating a label import)
790 parse2 "" header = parse4 "" header False nilFS
791 parse2 (' ':rest) header = parse2 rest header
792 parse2 ('&':rest) header = parse3 rest header True
793 parse2 str@('[':_ ) header = parse3 str header False
794 parse2 str header = parse4 str header False nilFS
795 -- check for library object name
796 parse3 (' ':rest) header isLbl = parse3 rest header isLbl
797 parse3 ('[':rest) header isLbl =
798 case break (== ']') rest of
799 (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
800 _ -> parseError loc "Missing ']' in entity"
801 parse3 str header isLbl = parse4 str header isLbl nilFS
802 -- check for name of C function
803 parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
804 parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
805 parse4 str header isLbl lib
806 | all (== ' ') rest = build (mkFastString first) header isLbl lib
807 | otherwise = parseError loc "Malformed entity string"
809 (first, rest) = break (== ' ') str
811 build cid header False lib = return $
812 CImport cconv safety header lib (CFunction (StaticTarget cid))
813 build cid header True lib = return $
814 CImport cconv safety header lib (CLabel cid )
817 -- Unravel a dotnet spec string.
819 parseDImport :: Located FastString -> P DNCallSpec
820 parseDImport (L loc entity) = parse0 comps
822 comps = words (unpackFS entity)
826 | x == "static" = parse1 True xs
827 | otherwise = parse1 False (x:xs)
830 parse1 isStatic (x:xs)
831 | x == "method" = parse2 isStatic DNMethod xs
832 | x == "field" = parse2 isStatic DNField xs
833 | x == "ctor" = parse2 isStatic DNConstructor xs
834 parse1 isStatic xs = parse2 isStatic DNMethod xs
837 parse2 isStatic kind (('[':x):xs) =
840 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
841 parse2 isStatic kind xs = parse3 isStatic kind "" xs
843 parse3 isStatic kind assem [x] =
844 return (DNCallSpec isStatic kind assem x
845 -- these will be filled in once known.
846 (error "FFI-dotnet-args")
847 (error "FFI-dotnet-result"))
848 parse3 _ _ _ _ = d'oh
850 d'oh = parseError loc "Malformed entity string"
852 -- construct a foreign export declaration
855 -> (Located FastString, Located RdrName, LHsType RdrName)
856 -> P (HsDecl RdrName)
857 mkExport (CCall cconv) (L loc entity, v, ty) = return $
858 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
860 entity' | nullFS entity = mkExtName (unLoc v)
862 mkExport DNCall (L loc entity, v, ty) =
863 parseError (getLoc v){-TODO: not quite right-}
864 "Foreign export is not yet supported for .NET"
866 -- Supplying the ext_name in a foreign decl is optional; if it
867 -- isn't there, the Haskell name is assumed. Note that no transformation
868 -- of the Haskell name is then performed, so if you foreign export (++),
869 -- it's external name will be "++". Too bad; it's important because we don't
870 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
872 mkExtName :: RdrName -> CLabelString
873 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
877 -----------------------------------------------------------------------------
881 showRdrName :: RdrName -> String
882 showRdrName r = showSDoc (ppr r)
884 parseError :: SrcSpan -> String -> P a
885 parseError span s = failSpanMsgP span s