2 % (c) The University of Glasgow, 1996-2003
4 Functions over HsSyn specialised to RdrName.
9 extractHsRhoRdrTyVars, extractGenericPatTyVars,
12 mkHsIntegral, mkHsFractional, mkHsIsString,
13 mkHsDo, mkHsSplice, mkTopSpliceDecl,
14 mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
15 splitCon, mkInlinePragma,
16 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
23 -- Stuff to do with Foreign declarations
27 mkExtName, -- RdrName -> CLabelString
28 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
30 mkDeprecatedGadtRecordDecl,
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 checkTyVars, -- [LHsType RdrName] -> P ()
38 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
39 checkInstType, -- HsType -> P HsType
40 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
51 import HsSyn -- Lots of it
52 import Class ( FunDep )
53 import TypeRep ( Kind )
54 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
55 isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
56 import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo,
59 import TysWiredIn ( unitTyCon )
61 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
63 import PrelNames ( forall_tv_RDR )
66 import OrdList ( OrdList, fromOL )
67 import Bag ( Bag, emptyBag, consBag, foldrBag )
72 import Control.Applicative ((<$>))
73 import Text.ParserCombinators.ReadP as ReadP
74 import Data.List ( nubBy )
77 #include "HsVersions.h"
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 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
95 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
97 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
98 -- This one takes the context and tau-part of a
99 -- sigma type and returns their free type variables
100 extractHsRhoRdrTyVars ctxt ty
101 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
103 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
104 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
106 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
107 extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
108 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
109 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
111 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
112 extract_ltys tys acc = foldr extract_lty acc tys
114 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
115 extract_lty (L loc ty) acc
117 HsTyVar tv -> extract_tv loc tv acc
118 HsBangTy _ ty -> extract_lty ty acc
119 HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
120 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
121 HsListTy ty -> extract_lty ty acc
122 HsPArrTy ty -> extract_lty ty acc
123 HsTupleTy _ tys -> extract_ltys tys acc
124 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
125 HsPredTy p -> extract_pred p acc
126 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
127 HsParTy ty -> extract_lty ty acc
129 HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
130 HsSpliceTy {} -> acc -- Type splices mention no type variables
131 HsKindSig ty _ -> extract_lty ty acc
132 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
133 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
134 extract_lctxt cx (extract_lty ty []))
136 locals = hsLTyVarNames tvs
137 HsDocTy ty _ -> extract_lty ty acc
139 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
140 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
143 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
144 -- Get the type variables out of the type patterns in a bunch of
145 -- possibly-generic bindings in a class declaration
146 extractGenericPatTyVars binds
147 = nubBy eqLocated (foldrBag get [] binds)
149 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
152 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
157 %************************************************************************
159 \subsection{Construction functions for Rdr stuff}
161 %************************************************************************
163 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
164 by deriving them from the name of the class. We fill in the names for the
165 tycon and datacon corresponding to the class, by deriving them from the
166 name of the class itself. This saves recording the names in the interface
167 file (which would be equally good).
169 Similarly for mkConDecl, mkClassOpSig and default-method names.
171 *** See "THE NAMING STORY" in HsDecls ****
174 mkClassDecl :: SrcSpan
175 -> Located (LHsContext RdrName, LHsType RdrName)
176 -> Located [Located (FunDep RdrName)]
177 -> Located (OrdList (LHsDecl RdrName))
178 -> P (LTyClDecl RdrName)
180 mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
181 = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
182 ; (cls, tparams) <- checkTyClHdr tycl_hdr
183 ; tyvars <- checkTyVars tparams -- Only type vars allowed
185 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
186 tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
187 tcdATs = ats, tcdDocs = docs })) }
191 -> Bool -- True <=> data family instance
192 -> Located (LHsContext RdrName, LHsType RdrName)
194 -> [LConDecl RdrName]
195 -> Maybe [LHsType RdrName]
196 -> P (LTyClDecl RdrName)
197 mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
198 = do { (tc, tparams) <- checkTyClHdr tycl_hdr
200 ; (tyvars, typats) <- checkTParams is_family tparams
201 ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
202 tcdTyVars = tyvars, tcdTyPats = typats,
204 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
206 mkTySynonym :: SrcSpan
207 -> Bool -- True <=> type family instances
208 -> LHsType RdrName -- LHS
209 -> LHsType RdrName -- RHS
210 -> P (LTyClDecl RdrName)
211 mkTySynonym loc is_family lhs rhs
212 = do { (tc, tparams) <- checkTyClHdr lhs
213 ; (tyvars, typats) <- checkTParams is_family tparams
214 ; return (L loc (TySynonym tc tyvars typats rhs)) }
216 mkTyFamily :: SrcSpan
218 -> LHsType RdrName -- LHS
219 -> Maybe Kind -- Optional kind signature
220 -> P (LTyClDecl RdrName)
221 mkTyFamily loc flavour lhs ksig
222 = do { (tc, tparams) <- checkTyClHdr lhs
223 ; tyvars <- checkTyVars tparams
224 ; return (L loc (TyFamily flavour tc tyvars ksig)) }
226 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
228 -- [pads| ... ] then return a QuasiQuoteD
229 -- $(e) then return a SpliceD
230 -- but if she wrote, say,
231 -- f x then behave as if she'd written $(f x)
233 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq
234 mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit)
235 mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit)
238 %************************************************************************
240 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
242 %************************************************************************
244 Function definitions are restructured here. Each is assumed to be recursive
245 initially, and non recursive definitions are discovered by the dependency
250 -- | Groups together bindings for a single function
251 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
252 cvTopDecls decls = go (fromOL decls)
254 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
256 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
257 where (L l' b', ds') = getMonoBind (L l b) ds
258 go (d : ds) = d : go ds
260 -- Declaration list may only contain value bindings and signatures.
261 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
263 = case cvBindsAndSigs binding of
264 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
267 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
268 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
269 -- Input decls contain just value bindings and signatures
270 -- and in case of class or instance declarations also
271 -- associated type declarations. They might also contain Haddock comments.
272 cvBindsAndSigs fb = go (fromOL fb)
274 go [] = (emptyBag, [], [], [])
275 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
276 where (bs, ss, ts, docs) = go ds
277 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
278 where (b', ds') = getMonoBind (L l b) ds
279 (bs, ss, ts, docs) = go ds'
280 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
281 where (bs, ss, ts, docs) = go ds
282 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
283 where (bs, ss, ts, docs) = go ds
284 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
286 -----------------------------------------------------------------------------
287 -- Group function bindings into equation groups
289 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
290 -> (LHsBind RdrName, [LHsDecl RdrName])
291 -- Suppose (b',ds') = getMonoBind b ds
292 -- ds is a list of parsed bindings
293 -- b is a MonoBinds that has just been read off the front
295 -- Then b' is the result of grouping more equations from ds that
296 -- belong with b into a single MonoBinds, and ds' is the depleted
297 -- list of parsed bindings.
299 -- All Haddock comments between equations inside the group are
302 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
304 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
305 fun_matches = MatchGroup mtchs1 _ })) binds
307 = go is_infix1 mtchs1 loc1 binds []
309 go is_infix mtchs loc
310 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
311 fun_matches = MatchGroup mtchs2 _ })) : binds) _
312 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
313 (combineSrcSpans loc loc2) binds []
314 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
315 = let doc_decls' = doc_decl : doc_decls
316 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
317 go is_infix mtchs loc binds doc_decls
318 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
319 -- Reverse the final matches, to get it back in the right order
320 -- Do the same thing with the trailing doc comments
322 getMonoBind bind binds = (bind, binds)
324 has_args :: [LMatch RdrName] -> Bool
325 has_args [] = panic "RdrHsSyn:has_args"
326 has_args ((L _ (Match args _ _)) : _) = not (null args)
327 -- Don't group together FunBinds if they have
328 -- no arguments. This is necessary now that variable bindings
329 -- with no arguments are now treated as FunBinds rather
330 -- than pattern bindings (tests/rename/should_fail/rnfail002).
333 %************************************************************************
335 \subsection[PrefixToHS-utils]{Utilities for conversion}
337 %************************************************************************
341 -----------------------------------------------------------------------------
344 -- When parsing data declarations, we sometimes inadvertently parse
345 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
346 -- This function splits up the type application, adds any pending
347 -- arguments, and converts the type constructor back into a data constructor.
349 splitCon :: LHsType RdrName
350 -> P (Located RdrName, HsConDeclDetails RdrName)
351 -- This gets given a "type" that should look like
353 -- or C { x::Int, y::Bool }
354 -- and returns the pieces
358 split (L _ (HsAppTy t u)) ts = split t (u : ts)
359 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
360 return (data_con, mk_rest ts)
361 split (L l _) _ = parseError l "parse error in data/newtype declaration"
363 mk_rest [L _ (HsRecTy flds)] = RecCon flds
364 mk_rest ts = PrefixCon ts
366 mkDeprecatedGadtRecordDecl :: SrcSpan
368 -> [ConDeclField RdrName]
370 -> P (LConDecl RdrName)
371 -- This one uses the deprecated syntax
372 -- C { x,y ::Int } :: T a b
373 -- We give it a RecCon details right away
374 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
375 = do { data_con <- tyConToDataCon con_loc con
376 ; return (L loc (ConDecl { con_old_rec = True
377 , con_name = data_con
378 , con_explicit = Implicit
381 , con_details = RecCon flds
382 , con_res = ResTyGADT res_ty
383 , con_doc = Nothing })) }
385 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
386 -> LHsContext RdrName -> HsConDeclDetails RdrName
389 mkSimpleConDecl name qvars cxt details
390 = ConDecl { con_old_rec = False
392 , con_explicit = Explicit
395 , con_details = details
397 , con_doc = Nothing }
399 mkGadtDecl :: [Located RdrName]
400 -> LHsType RdrName -- Always a HsForAllTy
402 -- We allow C,D :: ty
403 -- and expand it as if it had been
405 -- (Just like type signatures in general.)
406 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
407 = [mk_gadt_con name | name <- names]
409 (details, res_ty) -- See Note [Sorting out the result type]
411 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
412 _other -> (PrefixCon [], tau)
415 = ConDecl { con_old_rec = False
420 , con_details = details
421 , con_res = ResTyGADT res_ty
422 , con_doc = Nothing }
423 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
425 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
426 tyConToDataCon loc tc
427 | isTcOcc (rdrNameOcc tc)
428 = return (L loc (setRdrNameSpace tc srcDataName))
430 = parseErrorSDoc loc (msg $$ extra)
432 msg = text "Not a data constructor:" <+> quotes (ppr tc)
433 extra | tc == forall_tv_RDR
434 = text "Perhaps you intended to use -XExistentialQuantification"
438 Note [Sorting out the result type]
439 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
440 In a GADT declaration which is not a record, we put the whole constr
441 type into the ResTyGADT for now; the renamer will unravel it once it
442 has sorted out operator fixities. Consider for example
443 C :: a :*: b -> a :*: b -> a :+: b
444 Initially this type will parse as
445 a :*: (b -> (a :*: (b -> (a :+: b))))
447 so it's hard to split up the arguments until we've done the precedence
448 resolution (in the renamer) On the other hand, for a record
449 { x,y :: Int } -> a :*: b
450 there is no doubt. AND we need to sort records out so that
451 we can bring x,y into scope. So:
452 * For PrefixCon we keep all the args in the ResTyGADT
453 * For RecCon we do not
456 ----------------------------------------------------------------------------
457 -- Various Syntactic Checks
459 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
460 checkInstType (L l t)
462 HsForAllTy exp tvs ctxt ty -> do
463 dict_ty <- checkDictTy ty
464 return (L l (HsForAllTy exp tvs ctxt dict_ty))
466 HsParTy ty -> checkInstType ty
468 ty -> do dict_ty <- checkDictTy (L l ty)
469 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
471 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
472 checkDictTy (L spn ty) = check ty []
474 check (HsTyVar tc) args | isRdrTc tc = done tc args
475 check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
476 check (HsAppTy l r) args = check (unLoc l) (r:args)
477 check (HsParTy t) args = check (unLoc t) args
478 check _ _ = parseError spn "Malformed instance header"
480 done tc args = return (L spn (HsPredTy (HsClassP tc args)))
482 checkTParams :: Bool -- Type/data family
484 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
485 -- checkTParams checks the type parameters of a data/newtype declaration
486 -- There are two cases:
488 -- a) Vanilla data/newtype decl. In that case
489 -- - the type parameters should all be type variables
490 -- - they may have a kind annotation
492 -- b) Family data/newtype decl. In that case
493 -- - The type parameters may be arbitrary types
494 -- - We find the type-varaible binders by find the
495 -- free type vars of those types
496 -- - We make them all kind-sig-free binders (UserTyVar)
497 -- If there are kind sigs in the type parameters, they
498 -- will fix the binder's kind when we kind-check the
500 checkTParams is_family tparams
501 | not is_family -- Vanilla case (a)
502 = do { tyvars <- checkTyVars tparams
503 ; return (tyvars, Nothing) }
504 | otherwise -- Family case (b)
505 = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
506 ; return (tyvars, Just tparams) }
508 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
509 -- Check whether the given list of type parameters are all type variables
510 -- (possibly with a kind signature). If the second argument is `False',
511 -- only type variables are allowed and we raise an error on encountering a
512 -- non-variable; otherwise, we allow non-variable arguments and return the
513 -- entire list of parameters.
514 checkTyVars tparms = mapM chk tparms
516 -- Check that the name space is correct!
517 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
518 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
519 chk (L l (HsTyVar tv))
520 | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
522 parseError l "Type found where type variable expected"
524 checkTyClHdr :: LHsType RdrName
525 -> P (Located RdrName, -- the head symbol (type or class name)
526 [LHsType RdrName]) -- parameters of head symbol
527 -- Well-formedness check and decomposition of type and class heads.
528 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
529 -- Int :*: Bool into (:*:, [Int, Bool])
530 -- returning the pieces
534 goL (L l ty) acc = go l ty acc
536 go l (HsTyVar tc) acc
537 | isRdrTc tc = return (L l tc, acc)
539 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
540 | isRdrTc tc = return (ltc, t1:t2:acc)
541 go _ (HsParTy ty) acc = goL ty acc
542 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
543 go l _ _ = parseError l "Malformed head of type or class declaration"
545 -- Check that associated type declarations of a class are all kind signatures.
547 checkKindSigs :: [LTyClDecl RdrName] -> P ()
548 checkKindSigs = mapM_ check
551 | isFamilyDecl tydecl
552 || isSynDecl tydecl = return ()
554 parseError l "Type declaration in a class must be a kind signature or synonym default"
556 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
560 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
561 = do ctx <- mapM checkPred ts
564 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
567 check (HsTyVar t) -- Empty context shows up as a unit type ()
568 | t == getRdrName unitTyCon = return (L l [])
571 = do p <- checkPred (L l t)
575 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
576 -- Watch out.. in ...deriving( Show )... we use checkPred on
577 -- the list of partially applied predicates in the deriving,
578 -- so there can be zero args.
579 checkPred (L spn (HsPredTy (HsIParam n ty)))
580 = return (L spn (HsIParam n ty))
584 checkl (L l ty) args = check l ty args
586 check _loc (HsPredTy pred@(HsEqualP _ _))
588 = return $ L spn pred
589 check _loc (HsTyVar t) args | not (isRdrTyVar t)
590 = return (L spn (HsClassP t args))
591 check _loc (HsAppTy l r) args = checkl l (r:args)
592 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
593 check _loc (HsParTy t) args = checkl t args
594 check loc _ _ = parseError loc
595 "malformed class assertion"
597 ---------------------------------------------------------------------------
598 -- Checking statements in a do-expression
599 -- We parse do { e1 ; e2 ; }
600 -- as [ExprStmt e1, ExprStmt e2]
601 -- checkDo (a) checks that the last thing is an ExprStmt
602 -- (b) returns it separately
603 -- same comments apply for mdo as well
605 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
607 checkDo = checkDoMDo "a " "'do'"
608 checkMDo = checkDoMDo "an " "'mdo'"
610 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
611 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
612 checkDoMDo pre nm _ ss = do
615 check [] = panic "RdrHsSyn:checkDoMDo"
616 check [L _ (ExprStmt e _ _)] = return ([], e)
617 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
618 " construct must be an expression")
623 -- -------------------------------------------------------------------------
624 -- Checking Patterns.
626 -- We parse patterns as expressions and check for valid patterns below,
627 -- converting the expression into a pattern at the same time.
629 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
630 checkPattern e = checkLPat e
632 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
633 checkPatterns es = mapM checkPattern es
635 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
636 checkLPat e@(L l _) = checkPat l e []
638 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
639 checkPat loc (L l (HsVar c)) args
640 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
641 checkPat loc e args -- OK to let this happen even if bang-patterns
642 -- are not enabled, because there is no valid
643 -- non-bang-pattern parse of (C ! e)
644 | Just (e', args') <- splitBang e
645 = do { args'' <- checkPatterns args'
646 ; checkPat loc e' (args'' ++ args) }
647 checkPat loc (L _ (HsApp f x)) args
648 = do { x <- checkLPat x; checkPat loc f (x:args) }
649 checkPat loc (L _ e) []
650 = do { pState <- getPState
651 ; p <- checkAPat (dflags pState) loc e
656 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
657 checkAPat dynflags loc e = case e of
658 EWildPat -> return (WildPat placeHolderType)
659 HsVar x -> return (VarPat x)
660 HsLit l -> return (LitPat l)
662 -- Overloaded numeric patterns (e.g. f 0 x = x)
663 -- Negation is recorded separately, so that the literal is zero or +ve
664 -- NB. Negative *primitive* literals are already handled by the lexer
665 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
666 NegApp (L _ (HsOverLit pos_lit)) _
667 -> return (mkNPat pos_lit (Just noSyntaxExpr))
669 SectionR (L _ (HsVar bang)) e -- (! x)
671 -> do { bang_on <- extension bangPatEnabled
672 ; if bang_on then checkLPat e >>= (return . BangPat)
673 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
675 ELazyPat e -> checkLPat e >>= (return . LazyPat)
676 EAsPat n e -> checkLPat e >>= (return . AsPat n)
677 -- view pattern is well-formed if the pattern is
678 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
679 ExprWithTySig e t -> do e <- checkLPat e
680 -- Pattern signatures are parsed as sigtypes,
681 -- but they aren't explicit forall points. Hence
682 -- we have to remove the implicit forall here.
684 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
686 return (SigPatIn e t')
689 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
690 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
691 | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
692 -> return (mkNPlusKPat (L nloc n) lit)
694 OpApp l op _fix r -> do l <- checkLPat l
697 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
698 -> return (ConPatIn (L cl c) (InfixCon l r))
701 HsPar e -> checkLPat e >>= (return . ParPat)
702 ExplicitList _ es -> do ps <- mapM checkLPat es
703 return (ListPat ps placeHolderType)
704 ExplicitPArr _ es -> do ps <- mapM checkLPat es
705 return (PArrPat ps placeHolderType)
708 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
709 return (TuplePat ps b placeHolderType)
710 | otherwise -> parseError loc "Illegal tuple section in pattern"
712 RecordCon c _ (HsRecFields fs dd)
713 -> do fs <- mapM checkPatField fs
714 return (ConPatIn c (RecCon (HsRecFields fs dd)))
715 HsQuasiQuoteE q -> return (QuasiQuotePat q)
717 HsType ty -> return (TypePat ty)
720 placeHolderPunRhs :: LHsExpr RdrName
721 -- The RHS of a punned record field will be filled in by the renamer
722 -- It's better not to make it an error, in case we want to print it when debugging
723 placeHolderPunRhs = noLoc (HsVar pun_RDR)
725 plus_RDR, bang_RDR, pun_RDR :: RdrName
726 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
727 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
728 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
730 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
731 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
732 ; return (fld { hsRecFieldArg = p }) }
734 patFail :: SrcSpan -> P a
735 patFail loc = parseError loc "Parse error in pattern"
738 ---------------------------------------------------------------------------
739 -- Check Equation Syntax
741 checkValDef :: LHsExpr RdrName
742 -> Maybe (LHsType RdrName)
743 -> Located (GRHSs RdrName)
744 -> P (HsBind RdrName)
746 checkValDef lhs (Just sig) grhss
747 -- x :: ty = rhs parses as a *pattern* binding
748 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
750 checkValDef lhs opt_sig grhss
751 = do { mb_fun <- isFunLhs lhs
753 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
754 fun is_infix pats opt_sig grhss
755 Nothing -> checkPatBind lhs grhss }
757 checkFunBind :: SrcSpan
761 -> Maybe (LHsType RdrName)
762 -> Located (GRHSs RdrName)
763 -> P (HsBind RdrName)
764 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
765 = do ps <- checkPatterns pats
766 let match_span = combineSrcSpans lhs_loc rhs_span
767 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
768 -- The span of the match covers the entire equation.
769 -- That isn't quite right, but it'll do for now.
771 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
772 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
773 makeFunBind fn is_infix ms
774 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
775 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
777 checkPatBind :: LHsExpr RdrName
778 -> Located (GRHSs RdrName)
779 -> P (HsBind RdrName)
780 checkPatBind lhs (L _ grhss)
781 = do { lhs <- checkPattern lhs
782 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
788 checkValSig (L l (HsVar v)) ty
789 | isUnqual v && not (isDataOcc (rdrNameOcc v))
790 = return (TypeSig (L l v) ty)
791 checkValSig lhs@(L l _) _
792 | looks_like_foreign lhs
793 = parseError l "Invalid type signature; perhaps you meant to use -XForeignFunctionInterface?"
795 = parseError l "Invalid type signature: should be of form <variable> :: <type>"
797 -- A common error is to forget the ForeignFunctionInterface flag
798 -- so check for that, and suggest. cf Trac #3805
799 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
800 looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR
801 looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
802 looks_like_foreign _ = False
804 foreign_RDR = mkUnqual varName (fsLit "foreign")
809 -- The parser left-associates, so there should
810 -- not be any OpApps inside the e's
811 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
812 -- Splits (f ! g a b) into (f, [(! g), a, b])
813 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
814 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
816 (arg1,argns) = split_bang r_arg []
817 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
818 split_bang e es = (e,es)
819 splitBang _ = Nothing
821 isFunLhs :: LHsExpr RdrName
822 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
823 -- A variable binding is parsed as a FunBind.
824 -- Just (fun, is_infix, arg_pats) if e is a function LHS
826 -- The whole LHS is parsed as a single expression.
827 -- Any infix operators on the LHS will parse left-associatively
829 -- will parse (rather strangely) as
831 -- It's up to isFunLhs to sort out the mess
837 go (L loc (HsVar f)) es
838 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
839 go (L _ (HsApp f e)) es = go f (e:es)
840 go (L _ (HsPar e)) es@(_:_) = go e es
842 -- For infix function defns, there should be only one infix *function*
843 -- (though there may be infix *datacons* involved too). So we don't
844 -- need fixity info to figure out which function is being defined.
845 -- a `K1` b `op` c `K2` d
847 -- (a `K1` b) `op` (c `K2` d)
848 -- The renamer checks later that the precedences would yield such a parse.
850 -- There is a complication to deal with bang patterns.
852 -- ToDo: what about this?
853 -- x + 1 `op` y = ...
855 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
856 | Just (e',es') <- splitBang e
857 = do { bang_on <- extension bangPatEnabled
858 ; if bang_on then go e' (es' ++ es)
859 else return (Just (L loc' op, True, (l:r:es))) }
860 -- No bangs; behave just like the next case
861 | not (isRdrDataCon op) -- We have found the function!
862 = return (Just (L loc' op, True, (l:r:es)))
863 | otherwise -- Infix data con; keep going
864 = do { mb_l <- go l es
866 Just (op', True, j : k : es')
867 -> return (Just (op', True, j : op_app : es'))
869 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
870 _ -> return Nothing }
871 go _ _ = return Nothing
873 ---------------------------------------------------------------------------
874 -- Miscellaneous utilities
876 checkPrecP :: Located Int -> P Int
878 | 0 <= i && i <= maxPrecedence = return i
879 | otherwise = parseError l "Precedence out of range"
884 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
885 -> P (HsExpr RdrName)
887 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
888 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
889 mkRecConstrOrUpdate exp loc (fs,dd)
890 | null fs = parseError loc "Empty record update"
891 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
893 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
894 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
895 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
897 mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
898 -- The Maybe is because the user can omit the activation spec (and usually does)
899 mkInlinePragma mb_act match_info inl
900 = InlinePragma { inl_inline = inl
903 , inl_rule = match_info }
907 Nothing | inl -> AlwaysActive
908 | otherwise -> NeverActive
909 -- If no specific phase is given then:
910 -- NOINLINE => NeverActive
913 -----------------------------------------------------------------------------
914 -- utilities for foreign declarations
916 -- construct a foreign import declaration
918 mkImport :: CCallConv
920 -> (Located FastString, Located RdrName, LHsType RdrName)
921 -> P (HsDecl RdrName)
922 mkImport cconv safety (L loc entity, v, ty)
923 | cconv == PrimCallConv = do
924 let funcTarget = CFunction (StaticTarget entity Nothing)
925 importSpec = CImport PrimCallConv safety nilFS funcTarget
926 return (ForD (ForeignImport v ty importSpec))
929 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
930 Nothing -> parseError loc "Malformed entity string"
931 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
933 -- the string "foo" is ambigous: either a header or a C identifier. The
934 -- C identifier case comes first in the alternatives below, so we pick
936 parseCImport :: CCallConv -> Safety -> FastString -> String
937 -> Maybe ForeignImport
938 parseCImport cconv safety nm str =
939 listToMaybe $ map fst $ filter (null.snd) $
945 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
946 string "wrapper" >> return (mk nilFS CWrapper),
947 optional (string "static" >> skipSpaces) >>
948 (mk nilFS <$> cimp nm) +++
949 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
954 mk = CImport cconv safety
956 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
957 -- pretty much any char (depending on the platform),
958 -- so just accept any non-space character
959 id_char c = isAlphaNum c || c == '_'
961 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
962 +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
965 (do c <- satisfy (\c -> isAlpha c || c == '_')
966 cs <- many (satisfy id_char)
967 return (mkFastString (c:cs)))
970 -- construct a foreign export declaration
972 mkExport :: CCallConv
973 -> (Located FastString, Located RdrName, LHsType RdrName)
974 -> P (HsDecl RdrName)
975 mkExport cconv (L _ entity, v, ty) = return $
976 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
978 entity' | nullFS entity = mkExtName (unLoc v)
981 -- Supplying the ext_name in a foreign decl is optional; if it
982 -- isn't there, the Haskell name is assumed. Note that no transformation
983 -- of the Haskell name is then performed, so if you foreign export (++),
984 -- it's external name will be "++". Too bad; it's important because we don't
985 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
987 mkExtName :: RdrName -> CLabelString
988 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
992 -----------------------------------------------------------------------------
996 parseError :: SrcSpan -> String -> P a
997 parseError span s = parseErrorSDoc span (text s)
999 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1000 parseErrorSDoc span s = failSpanMsgP span s