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 checkMonadComp, -- P (HsStmtContext RdrName)
44 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
45 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 )
57 import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo,
58 InlinePragma(..), InlineSpec(..) )
60 import TysWiredIn ( unitTyCon )
62 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
64 import PrelNames ( forall_tv_RDR )
67 import OrdList ( OrdList, fromOL )
68 import Bag ( Bag, emptyBag, consBag, foldrBag )
73 import Control.Applicative ((<$>))
75 import Text.ParserCombinators.ReadP as ReadP
76 import Data.List ( nubBy )
79 #include "HsVersions.h"
83 %************************************************************************
85 \subsection{A few functions over HsSyn at RdrName}
87 %************************************************************************
89 extractHsTyRdrNames finds the free variables of a HsType
90 It's used when making the for-alls explicit.
93 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
94 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
96 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
97 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
99 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
100 -- This one takes the context and tau-part of a
101 -- sigma type and returns their free type variables
102 extractHsRhoRdrTyVars ctxt ty
103 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
105 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
106 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
108 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
109 extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
110 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
111 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
113 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
114 extract_ltys tys acc = foldr extract_lty acc tys
116 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
117 extract_lty (L loc ty) acc
119 HsTyVar tv -> extract_tv loc tv acc
120 HsBangTy _ ty -> extract_lty ty acc
121 HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
122 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
123 HsListTy ty -> extract_lty ty acc
124 HsPArrTy ty -> extract_lty ty acc
125 HsModalBoxType ecn ty -> extract_lty ty (extract_tv loc ecn acc)
126 HsTupleTy _ tys -> extract_ltys tys acc
127 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
128 HsPredTy p -> extract_pred p acc
129 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
130 HsParTy ty -> extract_lty ty acc
131 HsCoreTy {} -> acc -- The type is closed
132 HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
133 HsSpliceTy {} -> acc -- Type splices mention no type variables
134 HsKindSig ty _ -> extract_lty ty acc
135 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
136 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
137 extract_lctxt cx (extract_lty ty []))
139 locals = hsLTyVarNames tvs
140 HsDocTy ty _ -> extract_lty ty acc
142 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
143 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
146 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
147 -- Get the type variables out of the type patterns in a bunch of
148 -- possibly-generic bindings in a class declaration
149 extractGenericPatTyVars binds
150 = nubBy eqLocated (foldrBag get [] binds)
152 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
159 %************************************************************************
161 \subsection{Construction functions for Rdr stuff}
163 %************************************************************************
165 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
166 by deriving them from the name of the class. We fill in the names for the
167 tycon and datacon corresponding to the class, by deriving them from the
168 name of the class itself. This saves recording the names in the interface
169 file (which would be equally good).
171 Similarly for mkConDecl, mkClassOpSig and default-method names.
173 *** See "THE NAMING STORY" in HsDecls ****
176 mkClassDecl :: SrcSpan
177 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
178 -> Located [Located (FunDep RdrName)]
179 -> Located (OrdList (LHsDecl RdrName))
180 -> P (LTyClDecl RdrName)
182 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
183 = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
184 ; let cxt = fromMaybe (noLoc []) mcxt
185 ; (cls, tparams) <- checkTyClHdr tycl_hdr
186 ; tyvars <- checkTyVars tparams -- Only type vars allowed
188 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
189 tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
190 tcdATs = ats, tcdDocs = docs })) }
194 -> Bool -- True <=> data family instance
195 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
197 -> [LConDecl RdrName]
198 -> Maybe [LHsType RdrName]
199 -> P (LTyClDecl RdrName)
200 mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
201 = do { (tc, tparams) <- checkTyClHdr tycl_hdr
203 ; checkDatatypeContext mcxt
204 ; let cxt = fromMaybe (noLoc []) mcxt
205 ; (tyvars, typats) <- checkTParams is_family tparams
206 ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
207 tcdTyVars = tyvars, tcdTyPats = typats,
209 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
211 mkTySynonym :: SrcSpan
212 -> Bool -- True <=> type family instances
213 -> LHsType RdrName -- LHS
214 -> LHsType RdrName -- RHS
215 -> P (LTyClDecl RdrName)
216 mkTySynonym loc is_family lhs rhs
217 = do { (tc, tparams) <- checkTyClHdr lhs
218 ; (tyvars, typats) <- checkTParams is_family tparams
219 ; return (L loc (TySynonym tc tyvars typats rhs)) }
221 mkTyFamily :: SrcSpan
223 -> LHsType RdrName -- LHS
224 -> Maybe Kind -- Optional kind signature
225 -> P (LTyClDecl RdrName)
226 mkTyFamily loc flavour lhs ksig
227 = do { (tc, tparams) <- checkTyClHdr lhs
228 ; tyvars <- checkTyVars tparams
229 ; return (L loc (TyFamily flavour tc tyvars ksig)) }
231 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
233 -- [pads| ... ] then return a QuasiQuoteD
234 -- $(e) then return a SpliceD
235 -- but if she wrote, say,
236 -- f x then behave as if she'd written $(f x)
238 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq
239 mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit)
240 mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit)
243 %************************************************************************
245 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
247 %************************************************************************
249 Function definitions are restructured here. Each is assumed to be recursive
250 initially, and non recursive definitions are discovered by the dependency
255 -- | Groups together bindings for a single function
256 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
257 cvTopDecls decls = go (fromOL decls)
259 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
261 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
262 where (L l' b', ds') = getMonoBind (L l b) ds
263 go (d : ds) = d : go ds
265 -- Declaration list may only contain value bindings and signatures.
266 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
268 = case cvBindsAndSigs binding of
269 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
272 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
273 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
274 -- Input decls contain just value bindings and signatures
275 -- and in case of class or instance declarations also
276 -- associated type declarations. They might also contain Haddock comments.
277 cvBindsAndSigs fb = go (fromOL fb)
279 go [] = (emptyBag, [], [], [])
280 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
281 where (bs, ss, ts, docs) = go ds
282 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
283 where (b', ds') = getMonoBind (L l b) ds
284 (bs, ss, ts, docs) = go ds'
285 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
286 where (bs, ss, ts, docs) = go ds
287 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
288 where (bs, ss, ts, docs) = go ds
289 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
291 -----------------------------------------------------------------------------
292 -- Group function bindings into equation groups
294 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
295 -> (LHsBind RdrName, [LHsDecl RdrName])
296 -- Suppose (b',ds') = getMonoBind b ds
297 -- ds is a list of parsed bindings
298 -- b is a MonoBinds that has just been read off the front
300 -- Then b' is the result of grouping more equations from ds that
301 -- belong with b into a single MonoBinds, and ds' is the depleted
302 -- list of parsed bindings.
304 -- All Haddock comments between equations inside the group are
307 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
309 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
310 fun_matches = MatchGroup mtchs1 _ })) binds
312 = go is_infix1 mtchs1 loc1 binds []
314 go is_infix mtchs loc
315 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
316 fun_matches = MatchGroup mtchs2 _ })) : binds) _
317 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
318 (combineSrcSpans loc loc2) binds []
319 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
320 = let doc_decls' = doc_decl : doc_decls
321 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
322 go is_infix mtchs loc binds doc_decls
323 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
324 -- Reverse the final matches, to get it back in the right order
325 -- Do the same thing with the trailing doc comments
327 getMonoBind bind binds = (bind, binds)
329 has_args :: [LMatch RdrName] -> Bool
330 has_args [] = panic "RdrHsSyn:has_args"
331 has_args ((L _ (Match args _ _)) : _) = not (null args)
332 -- Don't group together FunBinds if they have
333 -- no arguments. This is necessary now that variable bindings
334 -- with no arguments are now treated as FunBinds rather
335 -- than pattern bindings (tests/rename/should_fail/rnfail002).
338 %************************************************************************
340 \subsection[PrefixToHS-utils]{Utilities for conversion}
342 %************************************************************************
346 -----------------------------------------------------------------------------
349 -- When parsing data declarations, we sometimes inadvertently parse
350 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
351 -- This function splits up the type application, adds any pending
352 -- arguments, and converts the type constructor back into a data constructor.
354 splitCon :: LHsType RdrName
355 -> P (Located RdrName, HsConDeclDetails RdrName)
356 -- This gets given a "type" that should look like
358 -- or C { x::Int, y::Bool }
359 -- and returns the pieces
363 split (L _ (HsAppTy t u)) ts = split t (u : ts)
364 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
365 return (data_con, mk_rest ts)
366 split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
368 mk_rest [L _ (HsRecTy flds)] = RecCon flds
369 mk_rest ts = PrefixCon ts
371 mkDeprecatedGadtRecordDecl :: SrcSpan
373 -> [ConDeclField RdrName]
375 -> P (LConDecl RdrName)
376 -- This one uses the deprecated syntax
377 -- C { x,y ::Int } :: T a b
378 -- We give it a RecCon details right away
379 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
380 = do { data_con <- tyConToDataCon con_loc con
381 ; return (L loc (ConDecl { con_old_rec = True
382 , con_name = data_con
383 , con_explicit = Implicit
386 , con_details = RecCon flds
387 , con_res = ResTyGADT res_ty
388 , con_doc = Nothing })) }
390 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
391 -> LHsContext RdrName -> HsConDeclDetails RdrName
394 mkSimpleConDecl name qvars cxt details
395 = ConDecl { con_old_rec = False
397 , con_explicit = Explicit
400 , con_details = details
402 , con_doc = Nothing }
404 mkGadtDecl :: [Located RdrName]
405 -> LHsType RdrName -- Always a HsForAllTy
407 -- We allow C,D :: ty
408 -- and expand it as if it had been
410 -- (Just like type signatures in general.)
411 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
412 = [mk_gadt_con name | name <- names]
414 (details, res_ty) -- See Note [Sorting out the result type]
416 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
417 _other -> (PrefixCon [], tau)
420 = ConDecl { con_old_rec = False
425 , con_details = details
426 , con_res = ResTyGADT res_ty
427 , con_doc = Nothing }
428 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
430 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
431 tyConToDataCon loc tc
432 | isTcOcc (rdrNameOcc tc)
433 = return (L loc (setRdrNameSpace tc srcDataName))
435 = parseErrorSDoc loc (msg $$ extra)
437 msg = text "Not a data constructor:" <+> quotes (ppr tc)
438 extra | tc == forall_tv_RDR
439 = text "Perhaps you intended to use -XExistentialQuantification"
443 Note [Sorting out the result type]
444 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
445 In a GADT declaration which is not a record, we put the whole constr
446 type into the ResTyGADT for now; the renamer will unravel it once it
447 has sorted out operator fixities. Consider for example
448 C :: a :*: b -> a :*: b -> a :+: b
449 Initially this type will parse as
450 a :*: (b -> (a :*: (b -> (a :+: b))))
452 so it's hard to split up the arguments until we've done the precedence
453 resolution (in the renamer) On the other hand, for a record
454 { x,y :: Int } -> a :*: b
455 there is no doubt. AND we need to sort records out so that
456 we can bring x,y into scope. So:
457 * For PrefixCon we keep all the args in the ResTyGADT
458 * For RecCon we do not
461 ----------------------------------------------------------------------------
462 -- Various Syntactic Checks
464 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
465 checkInstType (L l t)
467 HsForAllTy exp tvs ctxt ty -> do
468 dict_ty <- checkDictTy ty
469 return (L l (HsForAllTy exp tvs ctxt dict_ty))
471 HsParTy ty -> checkInstType ty
473 ty -> do dict_ty <- checkDictTy (L l ty)
474 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
476 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
477 checkDictTy (L spn ty) = check ty []
479 check (HsTyVar tc) args | isRdrTc tc = done tc args
480 check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
481 check (HsAppTy l r) args = check (unLoc l) (r:args)
482 check (HsParTy t) args = check (unLoc t) args
483 check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty)
485 done tc args = return (L spn (HsPredTy (HsClassP tc args)))
487 checkTParams :: Bool -- Type/data family
489 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
490 -- checkTParams checks the type parameters of a data/newtype declaration
491 -- There are two cases:
493 -- a) Vanilla data/newtype decl. In that case
494 -- - the type parameters should all be type variables
495 -- - they may have a kind annotation
497 -- b) Family data/newtype decl. In that case
498 -- - The type parameters may be arbitrary types
499 -- - We find the type-varaible binders by find the
500 -- free type vars of those types
501 -- - We make them all kind-sig-free binders (UserTyVar)
502 -- If there are kind sigs in the type parameters, they
503 -- will fix the binder's kind when we kind-check the
505 checkTParams is_family tparams
506 | not is_family -- Vanilla case (a)
507 = do { tyvars <- checkTyVars tparams
508 ; return (tyvars, Nothing) }
509 | otherwise -- Family case (b)
510 = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
511 ; return (tyvars, Just tparams) }
513 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
514 -- Check whether the given list of type parameters are all type variables
515 -- (possibly with a kind signature). If the second argument is `False',
516 -- only type variables are allowed and we raise an error on encountering a
517 -- non-variable; otherwise, we allow non-variable arguments and return the
518 -- entire list of parameters.
519 checkTyVars tparms = mapM chk tparms
521 -- Check that the name space is correct!
522 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
523 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
524 chk (L l (HsTyVar tv))
525 | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
527 parseErrorSDoc l (text "Type found:" <+> ppr t
528 $$ text "where type variable expected, in:" <+>
529 sep (map (pprParendHsType . unLoc) tparms))
531 checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
532 checkDatatypeContext Nothing = return ()
533 checkDatatypeContext (Just (L loc c))
534 = do allowed <- extension datatypeContextsEnabled
537 (text "Illegal datatype context (use -XDatatypeContexts):" <+>
540 checkTyClHdr :: LHsType RdrName
541 -> P (Located RdrName, -- the head symbol (type or class name)
542 [LHsType RdrName]) -- parameters of head symbol
543 -- Well-formedness check and decomposition of type and class heads.
544 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
545 -- Int :*: Bool into (:*:, [Int, Bool])
546 -- returning the pieces
550 goL (L l ty) acc = go l ty acc
552 go l (HsTyVar tc) acc
553 | isRdrTc tc = return (L l tc, acc)
555 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
556 | isRdrTc tc = return (ltc, t1:t2:acc)
557 go _ (HsParTy ty) acc = goL ty acc
558 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
559 go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
561 -- Check that associated type declarations of a class are all kind signatures.
563 checkKindSigs :: [LTyClDecl RdrName] -> P ()
564 checkKindSigs = mapM_ check
567 | isFamilyDecl tydecl
568 || isSynDecl tydecl = return ()
570 parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl)
572 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
576 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
577 = do ctx <- mapM checkPred ts
580 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
583 check (HsTyVar t) -- Empty context shows up as a unit type ()
584 | t == getRdrName unitTyCon = return (L l [])
587 = do p <- checkPred (L l t)
591 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
592 -- Watch out.. in ...deriving( Show )... we use checkPred on
593 -- the list of partially applied predicates in the deriving,
594 -- so there can be zero args.
595 checkPred (L spn (HsPredTy (HsIParam n ty)))
596 = return (L spn (HsIParam n ty))
600 checkl (L l ty) args = check l ty args
602 check _loc (HsPredTy pred@(HsEqualP _ _))
604 = return $ L spn pred
605 check _loc (HsTyVar t) args | not (isRdrTyVar t)
606 = return (L spn (HsClassP t args))
607 check _loc (HsAppTy l r) args = checkl l (r:args)
608 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
609 check _loc (HsParTy t) args = checkl t args
610 check loc _ _ = parseErrorSDoc loc
611 (text "malformed class assertion:" <+> ppr ty)
613 -- -------------------------------------------------------------------------
614 -- Checking Patterns.
616 -- We parse patterns as expressions and check for valid patterns below,
617 -- converting the expression into a pattern at the same time.
619 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
620 checkPattern e = checkLPat e
622 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
623 checkPatterns es = mapM checkPattern es
625 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
626 checkLPat e@(L l _) = checkPat l e []
628 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
629 checkPat loc (L l (HsVar c)) args
630 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
631 checkPat loc e args -- OK to let this happen even if bang-patterns
632 -- are not enabled, because there is no valid
633 -- non-bang-pattern parse of (C ! e)
634 | Just (e', args') <- splitBang e
635 = do { args'' <- checkPatterns args'
636 ; checkPat loc e' (args'' ++ args) }
637 checkPat loc (L _ (HsApp f x)) args
638 = do { x <- checkLPat x; checkPat loc f (x:args) }
639 checkPat loc (L _ e) []
640 = do { pState <- getPState
641 ; p <- checkAPat (dflags pState) loc e
644 = patFail loc (unLoc e)
646 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
647 checkAPat dynflags loc e0 = case e0 of
648 EWildPat -> return (WildPat placeHolderType)
649 HsVar x -> return (VarPat x)
650 HsHetMetBrak _ p -> checkAPat dynflags loc (unLoc p)
651 HsLit l -> return (LitPat l)
653 -- Overloaded numeric patterns (e.g. f 0 x = x)
654 -- Negation is recorded separately, so that the literal is zero or +ve
655 -- NB. Negative *primitive* literals are already handled by the lexer
656 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
657 NegApp (L _ (HsOverLit pos_lit)) _
658 -> return (mkNPat pos_lit (Just noSyntaxExpr))
660 SectionR (L _ (HsVar bang)) e -- (! x)
662 -> do { bang_on <- extension bangPatEnabled
663 ; if bang_on then checkLPat e >>= (return . BangPat)
664 else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) }
666 ELazyPat e -> checkLPat e >>= (return . LazyPat)
667 EAsPat n e -> checkLPat e >>= (return . AsPat n)
668 -- view pattern is well-formed if the pattern is
669 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
670 ExprWithTySig e t -> do e <- checkLPat e
671 -- Pattern signatures are parsed as sigtypes,
672 -- but they aren't explicit forall points. Hence
673 -- we have to remove the implicit forall here.
675 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
677 return (SigPatIn e t')
680 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
681 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
682 | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
683 -> return (mkNPlusKPat (L nloc n) lit)
685 OpApp l op _fix r -> do l <- checkLPat l
688 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
689 -> return (ConPatIn (L cl c) (InfixCon l r))
692 HsPar e -> checkLPat e >>= (return . ParPat)
693 ExplicitList _ es -> do ps <- mapM checkLPat es
694 return (ListPat ps placeHolderType)
695 ExplicitPArr _ es -> do ps <- mapM checkLPat es
696 return (PArrPat ps placeHolderType)
699 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
700 return (TuplePat ps b placeHolderType)
701 | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
703 RecordCon c _ (HsRecFields fs dd)
704 -> do fs <- mapM checkPatField fs
705 return (ConPatIn c (RecCon (HsRecFields fs dd)))
706 HsQuasiQuoteE q -> return (QuasiQuotePat q)
709 placeHolderPunRhs :: LHsExpr RdrName
710 -- The RHS of a punned record field will be filled in by the renamer
711 -- It's better not to make it an error, in case we want to print it when debugging
712 placeHolderPunRhs = noLoc (HsVar pun_RDR)
714 plus_RDR, bang_RDR, pun_RDR :: RdrName
715 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
716 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
717 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
719 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
720 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
721 ; return (fld { hsRecFieldArg = p }) }
723 patFail :: SrcSpan -> HsExpr RdrName -> P a
724 patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e)
727 ---------------------------------------------------------------------------
728 -- Check Equation Syntax
730 checkValDef :: LHsExpr RdrName
731 -> Maybe (LHsType RdrName)
732 -> Located (GRHSs RdrName)
733 -> P (HsBind RdrName)
735 checkValDef lhs (Just sig) grhss
736 -- x :: ty = rhs parses as a *pattern* binding
737 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
739 checkValDef lhs opt_sig grhss
740 = do { mb_fun <- isFunLhs lhs
742 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
743 fun is_infix pats opt_sig grhss
744 Nothing -> checkPatBind lhs grhss }
746 checkFunBind :: SrcSpan
750 -> Maybe (LHsType RdrName)
751 -> Located (GRHSs RdrName)
752 -> P (HsBind RdrName)
753 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
754 = do ps <- checkPatterns pats
755 let match_span = combineSrcSpans lhs_loc rhs_span
756 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
757 -- The span of the match covers the entire equation.
758 -- That isn't quite right, but it'll do for now.
760 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
761 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
762 makeFunBind fn is_infix ms
763 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
764 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
766 checkPatBind :: LHsExpr RdrName
767 -> Located (GRHSs RdrName)
768 -> P (HsBind RdrName)
769 checkPatBind lhs (L _ grhss)
770 = do { lhs <- checkPattern lhs
771 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
777 checkValSig (L l (HsHetMetBrak _ e)) ty
779 checkValSig (L l (HsVar v)) ty
780 | isUnqual v && not (isDataOcc (rdrNameOcc v))
781 = return (TypeSig (L l v) ty)
782 checkValSig lhs@(L l _) ty
783 = parseErrorSDoc l ((text "Invalid type signature:" <+>
784 ppr lhs <+> text "::" <+> ppr ty)
787 hint = if foreign_RDR `looks_like` lhs
788 then "Perhaps you meant to use -XForeignFunctionInterface?"
789 else if default_RDR `looks_like` lhs
790 then "Perhaps you meant to use -XDefaultSignatures?"
791 else "Should be of form <variable> :: <type>"
792 -- A common error is to forget the ForeignFunctionInterface flag
793 -- so check for that, and suggest. cf Trac #3805
794 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
795 looks_like s (L _ (HsVar v)) = v == s
796 looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
797 looks_like _ _ = False
799 foreign_RDR = mkUnqual varName (fsLit "foreign")
800 default_RDR = mkUnqual varName (fsLit "default")
802 checkDoAndIfThenElse :: LHsExpr RdrName
808 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
809 | semiThen || semiElse
810 = do pState <- getPState
811 unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do
812 parseErrorSDoc (combineLocs guardExpr elseExpr)
813 (text "Unexpected semi-colons in conditional:"
815 $$ text "Perhaps you meant to use -XDoAndIfThenElse?")
816 | otherwise = return ()
817 where pprOptSemi True = semi
818 pprOptSemi False = empty
819 expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
820 text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
821 text "else" <+> ppr elseExpr
826 -- The parser left-associates, so there should
827 -- not be any OpApps inside the e's
828 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
829 -- Splits (f ! g a b) into (f, [(! g), a, b])
830 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
831 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
833 (arg1,argns) = split_bang r_arg []
834 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
835 split_bang e es = (e,es)
836 splitBang _ = Nothing
838 isFunLhs :: LHsExpr RdrName
839 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
840 -- A variable binding is parsed as a FunBind.
841 -- Just (fun, is_infix, arg_pats) if e is a function LHS
843 -- The whole LHS is parsed as a single expression.
844 -- Any infix operators on the LHS will parse left-associatively
846 -- will parse (rather strangely) as
848 -- It's up to isFunLhs to sort out the mess
854 go (L loc (HsVar f)) es
855 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
856 go (L _ (HsApp f e)) es = go f (e:es)
857 go (L _ (HsPar e)) es@(_:_) = go e es
859 -- For infix function defns, there should be only one infix *function*
860 -- (though there may be infix *datacons* involved too). So we don't
861 -- need fixity info to figure out which function is being defined.
862 -- a `K1` b `op` c `K2` d
864 -- (a `K1` b) `op` (c `K2` d)
865 -- The renamer checks later that the precedences would yield such a parse.
867 -- There is a complication to deal with bang patterns.
869 -- ToDo: what about this?
870 -- x + 1 `op` y = ...
872 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
873 | Just (e',es') <- splitBang e
874 = do { bang_on <- extension bangPatEnabled
875 ; if bang_on then go e' (es' ++ es)
876 else return (Just (L loc' op, True, (l:r:es))) }
877 -- No bangs; behave just like the next case
878 | not (isRdrDataCon op) -- We have found the function!
879 = return (Just (L loc' op, True, (l:r:es)))
880 | otherwise -- Infix data con; keep going
881 = do { mb_l <- go l es
883 Just (op', True, j : k : es')
884 -> return (Just (op', True, j : op_app : es'))
886 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
887 _ -> return Nothing }
888 go _ _ = return Nothing
891 ---------------------------------------------------------------------------
892 -- Check for monad comprehensions
894 -- If the flag MonadComprehensions is set, return a `MonadComp' context,
895 -- otherwise use the usual `ListComp' context
897 checkMonadComp :: P (HsStmtContext Name)
900 return $ if xopt Opt_MonadComprehensions (dflags pState)
904 ---------------------------------------------------------------------------
905 -- Miscellaneous utilities
907 checkPrecP :: Located Int -> P Int
909 | 0 <= i && i <= maxPrecedence = return i
911 = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
916 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
917 -> P (HsExpr RdrName)
919 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
920 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
921 mkRecConstrOrUpdate exp loc (fs,dd)
922 | null fs = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp)
923 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
925 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
926 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
927 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
929 mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
930 -- The Maybe is because the user can omit the activation spec (and usually does)
931 mkInlinePragma (inl, match_info) mb_act
932 = InlinePragma { inl_inline = inl
935 , inl_rule = match_info }
939 Nothing -> -- No phase specified
941 NoInline -> NeverActive
942 _other -> AlwaysActive
944 -----------------------------------------------------------------------------
945 -- utilities for foreign declarations
947 -- construct a foreign import declaration
949 mkImport :: CCallConv
951 -> (Located FastString, Located RdrName, LHsType RdrName)
952 -> P (HsDecl RdrName)
953 mkImport cconv safety (L loc entity, v, ty)
954 | cconv == PrimCallConv = do
955 let funcTarget = CFunction (StaticTarget entity Nothing)
956 importSpec = CImport PrimCallConv safety nilFS funcTarget
957 return (ForD (ForeignImport v ty importSpec))
960 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
961 Nothing -> parseErrorSDoc loc (text "Malformed entity string")
962 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
964 -- the string "foo" is ambigous: either a header or a C identifier. The
965 -- C identifier case comes first in the alternatives below, so we pick
967 parseCImport :: CCallConv -> Safety -> FastString -> String
968 -> Maybe ForeignImport
969 parseCImport cconv safety nm str =
970 listToMaybe $ map fst $ filter (null.snd) $
976 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
977 string "wrapper" >> return (mk nilFS CWrapper),
978 optional (string "static" >> skipSpaces) >>
979 (mk nilFS <$> cimp nm) +++
980 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
985 mk = CImport cconv safety
987 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
988 -- pretty much any char (depending on the platform),
989 -- so just accept any non-space character
990 id_char c = isAlphaNum c || c == '_'
992 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
993 +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
996 (do c <- satisfy (\c -> isAlpha c || c == '_')
997 cs <- many (satisfy id_char)
998 return (mkFastString (c:cs)))
1001 -- construct a foreign export declaration
1003 mkExport :: CCallConv
1004 -> (Located FastString, Located RdrName, LHsType RdrName)
1005 -> P (HsDecl RdrName)
1006 mkExport cconv (L _ entity, v, ty) = return $
1007 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1009 entity' | nullFS entity = mkExtName (unLoc v)
1010 | otherwise = entity
1012 -- Supplying the ext_name in a foreign decl is optional; if it
1013 -- isn't there, the Haskell name is assumed. Note that no transformation
1014 -- of the Haskell name is then performed, so if you foreign export (++),
1015 -- it's external name will be "++". Too bad; it's important because we don't
1016 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1018 mkExtName :: RdrName -> CLabelString
1019 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1023 -----------------------------------------------------------------------------
1027 parseError :: SrcSpan -> String -> P a
1028 parseError span s = parseErrorSDoc span (text s)
1030 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1031 parseErrorSDoc span s = failSpanMsgP span s