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
21 findSplice, checkDecBrGroup,
24 -- Stuff to do with Foreign declarations
28 mkExtName, -- RdrName -> CLabelString
29 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
31 mkDeprecatedGadtRecordDecl,
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 checkTyVars, -- [LHsType RdrName] -> P ()
39 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
40 checkInstType, -- HsType -> P HsType
41 checkPattern, -- HsExp -> P HsPat
43 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
44 checkDo, -- [Stmt] -> P [Stmt]
45 checkMDo, -- [Stmt] -> P [Stmt]
46 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
47 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
52 import HsSyn -- Lots of it
53 import Class ( FunDep )
54 import TypeRep ( Kind )
55 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
56 isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
57 import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo,
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, snocBag, consBag, foldrBag )
73 import Control.Applicative ((<$>))
74 import Text.ParserCombinators.ReadP as ReadP
75 import Data.List ( nubBy )
78 #include "HsVersions.h"
82 %************************************************************************
84 \subsection{A few functions over HsSyn at RdrName}
86 %************************************************************************
88 extractHsTyRdrNames finds the free variables of a HsType
89 It's used when making the for-alls explicit.
92 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
93 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
95 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
96 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
98 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
99 -- This one takes the context and tau-part of a
100 -- sigma type and returns their free type variables
101 extractHsRhoRdrTyVars ctxt ty
102 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
104 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
105 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
107 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
108 extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
109 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
110 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
112 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
113 extract_ltys tys acc = foldr extract_lty acc tys
115 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
116 extract_lty (L loc ty) acc
118 HsTyVar tv -> extract_tv loc tv acc
119 HsBangTy _ ty -> extract_lty ty acc
120 HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
121 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
122 HsListTy ty -> extract_lty ty acc
123 HsPArrTy ty -> extract_lty ty acc
124 HsTupleTy _ tys -> extract_ltys tys acc
125 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
126 HsPredTy p -> extract_pred p acc
127 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
128 HsParTy ty -> extract_lty ty acc
130 HsSpliceTy {} -> acc -- Type splices mention no type variables
131 HsSpliceTyOut {} -> acc -- Type splices mention no type variables
132 HsKindSig ty _ -> extract_lty ty acc
133 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
134 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
135 extract_lctxt cx (extract_lty ty []))
137 locals = hsLTyVarNames tvs
138 HsDocTy ty _ -> extract_lty ty acc
140 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
141 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
144 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
145 -- Get the type variables out of the type patterns in a bunch of
146 -- possibly-generic bindings in a class declaration
147 extractGenericPatTyVars binds
148 = nubBy eqLocated (foldrBag get [] binds)
150 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
153 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
158 %************************************************************************
160 \subsection{Construction functions for Rdr stuff}
162 %************************************************************************
164 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
165 by deriving them from the name of the class. We fill in the names for the
166 tycon and datacon corresponding to the class, by deriving them from the
167 name of the class itself. This saves recording the names in the interface
168 file (which would be equally good).
170 Similarly for mkConDecl, mkClassOpSig and default-method names.
172 *** See "THE NAMING STORY" in HsDecls ****
175 mkClassDecl :: SrcSpan
176 -> Located (LHsContext RdrName, LHsType RdrName)
177 -> Located [Located (FunDep RdrName)]
178 -> Located (OrdList (LHsDecl RdrName))
179 -> P (LTyClDecl RdrName)
181 mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
182 = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
183 ; (cls, tparams) <- checkTyClHdr tycl_hdr
184 ; tyvars <- checkTyVars tparams -- Only type vars allowed
186 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
187 tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
188 tcdATs = ats, tcdDocs = docs })) }
192 -> Bool -- True <=> data family instance
193 -> Located (LHsContext RdrName, LHsType RdrName)
195 -> [LConDecl RdrName]
196 -> Maybe [LHsType RdrName]
197 -> P (LTyClDecl RdrName)
198 mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
199 = do { (tc, tparams) <- checkTyClHdr tycl_hdr
201 ; (tyvars, typats) <- checkTParams is_family tparams
202 ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
203 tcdTyVars = tyvars, tcdTyPats = typats,
205 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
207 mkTySynonym :: SrcSpan
208 -> Bool -- True <=> type family instances
209 -> LHsType RdrName -- LHS
210 -> LHsType RdrName -- RHS
211 -> P (LTyClDecl RdrName)
212 mkTySynonym loc is_family lhs rhs
213 = do { (tc, tparams) <- checkTyClHdr lhs
214 ; (tyvars, typats) <- checkTParams is_family tparams
215 ; return (L loc (TySynonym tc tyvars typats rhs)) }
217 mkTyFamily :: SrcSpan
219 -> LHsType RdrName -- LHS
220 -> Maybe Kind -- Optional kind signature
221 -> P (LTyClDecl RdrName)
222 mkTyFamily loc flavour lhs ksig
223 = do { (tc, tparams) <- checkTyClHdr lhs
224 ; tyvars <- checkTyVars tparams
225 ; return (L loc (TyFamily flavour tc tyvars ksig)) }
227 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
230 -- then that's the splice, but if she wrote, say,
232 -- then behave as if she'd written
235 = SpliceD (SpliceDecl expr')
238 (L _ (HsSpliceE (HsSplice _ expr))) -> expr
242 %************************************************************************
244 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
246 %************************************************************************
248 Function definitions are restructured here. Each is assumed to be recursive
249 initially, and non recursive definitions are discovered by the dependency
254 -- | Groups together bindings for a single function
255 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
256 cvTopDecls decls = go (fromOL decls)
258 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
260 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
261 where (L l' b', ds') = getMonoBind (L l b) ds
262 go (d : ds) = d : go ds
264 -- Declaration list may only contain value bindings and signatures.
265 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
267 = case cvBindsAndSigs binding of
268 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
271 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
272 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
273 -- Input decls contain just value bindings and signatures
274 -- and in case of class or instance declarations also
275 -- associated type declarations. They might also contain Haddock comments.
276 cvBindsAndSigs fb = go (fromOL fb)
278 go [] = (emptyBag, [], [], [])
279 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
280 where (bs, ss, ts, docs) = go ds
281 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
282 where (b', ds') = getMonoBind (L l b) ds
283 (bs, ss, ts, docs) = go ds'
284 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
285 where (bs, ss, ts, docs) = go ds
286 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
287 where (bs, ss, ts, docs) = go ds
288 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
290 -----------------------------------------------------------------------------
291 -- Group function bindings into equation groups
293 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
294 -> (LHsBind RdrName, [LHsDecl RdrName])
295 -- Suppose (b',ds') = getMonoBind b ds
296 -- ds is a list of parsed bindings
297 -- b is a MonoBinds that has just been read off the front
299 -- Then b' is the result of grouping more equations from ds that
300 -- belong with b into a single MonoBinds, and ds' is the depleted
301 -- list of parsed bindings.
303 -- All Haddock comments between equations inside the group are
306 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
308 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
309 fun_matches = MatchGroup mtchs1 _ })) binds
311 = go is_infix1 mtchs1 loc1 binds []
313 go is_infix mtchs loc
314 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
315 fun_matches = MatchGroup mtchs2 _ })) : binds) _
316 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
317 (combineSrcSpans loc loc2) binds []
318 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
319 = let doc_decls' = doc_decl : doc_decls
320 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
321 go is_infix mtchs loc binds doc_decls
322 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
323 -- Reverse the final matches, to get it back in the right order
324 -- Do the same thing with the trailing doc comments
326 getMonoBind bind binds = (bind, binds)
328 has_args :: [LMatch RdrName] -> Bool
329 has_args [] = panic "RdrHsSyn:has_args"
330 has_args ((L _ (Match args _ _)) : _) = not (null args)
331 -- Don't group together FunBinds if they have
332 -- no arguments. This is necessary now that variable bindings
333 -- with no arguments are now treated as FunBinds rather
334 -- than pattern bindings (tests/rename/should_fail/rnfail002).
338 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
339 findSplice ds = addl emptyRdrGroup ds
341 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
342 -- Turn the body of a [d| ... |] into a HsGroup
343 -- There should be no splices in the "..."
344 checkDecBrGroup decls
345 = case addl emptyRdrGroup decls of
346 (group, Nothing) -> return group
347 (_, Just (SpliceDecl (L loc _), _)) ->
348 parseError loc "Declaration splices are not permitted inside declaration brackets"
349 -- Why not? See Section 7.3 of the TH paper.
351 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
352 -- This stuff reverses the declarations (again) but it doesn't matter
355 addl gp [] = (gp, Nothing)
356 addl gp (L l d : ds) = add gp l d ds
359 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
360 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
362 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
364 -- Class declarations: pull out the fixity signatures to the top
365 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
368 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
369 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
371 addl (gp { hs_tyclds = L l d : ts }) ds
373 -- Signatures: fixity sigs go a different place than all others
374 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
375 = addl (gp {hs_fixds = L l f : ts}) ds
376 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
377 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
379 -- Value declarations: use add_bind
380 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
381 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
383 -- The rest are routine
384 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
385 = addl (gp { hs_instds = L l d : ts }) ds
386 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
387 = addl (gp { hs_derivds = L l d : ts }) ds
388 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
389 = addl (gp { hs_defds = L l d : ts }) ds
390 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
391 = addl (gp { hs_fords = L l d : ts }) ds
392 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
393 = addl (gp { hs_warnds = L l d : ts }) ds
394 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
395 = addl (gp { hs_annds = L l d : ts }) ds
396 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
397 = addl (gp { hs_ruleds = L l d : ts }) ds
400 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
402 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
403 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
404 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
406 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
407 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
408 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
411 %************************************************************************
413 \subsection[PrefixToHS-utils]{Utilities for conversion}
415 %************************************************************************
419 -----------------------------------------------------------------------------
422 -- When parsing data declarations, we sometimes inadvertently parse
423 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
424 -- This function splits up the type application, adds any pending
425 -- arguments, and converts the type constructor back into a data constructor.
427 splitCon :: LHsType RdrName
428 -> P (Located RdrName, HsConDeclDetails RdrName)
429 -- This gets given a "type" that should look like
431 -- or C { x::Int, y::Bool }
432 -- and returns the pieces
436 split (L _ (HsAppTy t u)) ts = split t (u : ts)
437 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
438 return (data_con, mk_rest ts)
439 split (L l _) _ = parseError l "parse error in data/newtype declaration"
441 mk_rest [L _ (HsRecTy flds)] = RecCon flds
442 mk_rest ts = PrefixCon ts
444 mkDeprecatedGadtRecordDecl :: SrcSpan
446 -> [ConDeclField RdrName]
448 -> P (LConDecl RdrName)
449 -- This one uses the deprecated syntax
450 -- C { x,y ::Int } :: T a b
451 -- We give it a RecCon details right away
452 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
453 = do { data_con <- tyConToDataCon con_loc con
454 ; return (L loc (ConDecl { con_old_rec = True
455 , con_name = data_con
456 , con_explicit = Implicit
459 , con_details = RecCon flds
460 , con_res = ResTyGADT res_ty
461 , con_doc = Nothing })) }
463 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
464 -> LHsContext RdrName -> HsConDeclDetails RdrName
467 mkSimpleConDecl name qvars cxt details
468 = ConDecl { con_old_rec = False
470 , con_explicit = Explicit
473 , con_details = details
475 , con_doc = Nothing }
477 mkGadtDecl :: [Located RdrName]
478 -> LHsType RdrName -- Always a HsForAllTy
480 -- We allow C,D :: ty
481 -- and expand it as if it had been
483 -- (Just like type signatures in general.)
484 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
485 = [mk_gadt_con name | name <- names]
487 (details, res_ty) -- See Note [Sorting out the result type]
489 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
490 _other -> (PrefixCon [], tau)
493 = ConDecl { con_old_rec = False
498 , con_details = details
499 , con_res = ResTyGADT res_ty
500 , con_doc = Nothing }
501 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
503 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
504 tyConToDataCon loc tc
505 | isTcOcc (rdrNameOcc tc)
506 = return (L loc (setRdrNameSpace tc srcDataName))
508 = parseErrorSDoc loc (msg $$ extra)
510 msg = text "Not a data constructor:" <+> quotes (ppr tc)
511 extra | tc == forall_tv_RDR
512 = text "Perhaps you intended to use -XExistentialQuantification"
516 Note [Sorting out the result type]
517 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
518 In a GADT declaration which is not a record, we put the whole constr
519 type into the ResTyGADT for now; the renamer will unravel it once it
520 has sorted out operator fixities. Consider for example
521 C :: a :*: b -> a :*: b -> a :+: b
522 Initially this type will parse as
523 a :*: (b -> (a :*: (b -> (a :+: b))))
525 so it's hard to split up the arguments until we've done the precedence
526 resolution (in the renamer) On the other hand, for a record
527 { x,y :: Int } -> a :*: b
528 there is no doubt. AND we need to sort records out so that
529 we can bring x,y into scope. So:
530 * For PrefixCon we keep all the args in the ResTyGADT
531 * For RecCon we do not
534 ----------------------------------------------------------------------------
535 -- Various Syntactic Checks
537 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
538 checkInstType (L l t)
540 HsForAllTy exp tvs ctxt ty -> do
541 dict_ty <- checkDictTy ty
542 return (L l (HsForAllTy exp tvs ctxt dict_ty))
544 HsParTy ty -> checkInstType ty
546 ty -> do dict_ty <- checkDictTy (L l ty)
547 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
549 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
550 checkDictTy (L spn ty) = check ty []
552 check (HsTyVar t) args | not (isRdrTyVar t)
553 = return (L spn (HsPredTy (HsClassP t args)))
554 check (HsAppTy l r) args = check (unLoc l) (r:args)
555 check (HsParTy t) args = check (unLoc t) args
556 check _ _ = parseError spn "Malformed instance header"
558 checkTParams :: Bool -- Type/data family
560 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
561 -- checkTParams checks the type parameters of a data/newtype declaration
562 -- There are two cases:
564 -- a) Vanilla data/newtype decl. In that case
565 -- - the type parameters should all be type variables
566 -- - they may have a kind annotation
568 -- b) Family data/newtype decl. In that case
569 -- - The type parameters may be arbitrary types
570 -- - We find the type-varaible binders by find the
571 -- free type vars of those types
572 -- - We make them all kind-sig-free binders (UserTyVar)
573 -- If there are kind sigs in the type parameters, they
574 -- will fix the binder's kind when we kind-check the
576 checkTParams is_family tparams
577 | not is_family -- Vanilla case (a)
578 = do { tyvars <- checkTyVars tparams
579 ; return (tyvars, Nothing) }
580 | otherwise -- Family case (b)
581 = do { let tyvars = [L l (UserTyVar tv)
582 | L l tv <- extractHsTysRdrTyVars tparams]
583 ; return (tyvars, Just tparams) }
585 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
586 -- Check whether the given list of type parameters are all type variables
587 -- (possibly with a kind signature). If the second argument is `False',
588 -- only type variables are allowed and we raise an error on encountering a
589 -- non-variable; otherwise, we allow non-variable arguments and return the
590 -- entire list of parameters.
591 checkTyVars tparms = mapM chk tparms
593 -- Check that the name space is correct!
594 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
595 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
596 chk (L l (HsTyVar tv))
597 | isRdrTyVar tv = return (L l (UserTyVar tv))
599 parseError l "Type found where type variable expected"
601 checkTyClHdr :: LHsType RdrName
602 -> P (Located RdrName, -- the head symbol (type or class name)
603 [LHsType RdrName]) -- parameters of head symbol
604 -- Well-formedness check and decomposition of type and class heads.
605 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
606 -- Int :*: Bool into (:*:, [Int, Bool])
607 -- returning the pieces
611 goL (L l ty) acc = go l ty acc
613 go l (HsTyVar tc) acc
614 | isRdrTc tc = return (L l tc, acc)
616 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
617 | isRdrTc tc = return (ltc, t1:t2:acc)
618 go _ (HsParTy ty) acc = goL ty acc
619 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
620 go l _ _ = parseError l "Malformed head of type or class declaration"
622 -- Check that associated type declarations of a class are all kind signatures.
624 checkKindSigs :: [LTyClDecl RdrName] -> P ()
625 checkKindSigs = mapM_ check
628 | isFamilyDecl tydecl
629 || isSynDecl tydecl = return ()
631 parseError l "Type declaration in a class must be a kind signature or synonym default"
633 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
637 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
638 = do ctx <- mapM checkPred ts
641 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
644 check (HsTyVar t) -- Empty context shows up as a unit type ()
645 | t == getRdrName unitTyCon = return (L l [])
648 = do p <- checkPred (L l t)
652 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
653 -- Watch out.. in ...deriving( Show )... we use checkPred on
654 -- the list of partially applied predicates in the deriving,
655 -- so there can be zero args.
656 checkPred (L spn (HsPredTy (HsIParam n ty)))
657 = return (L spn (HsIParam n ty))
661 checkl (L l ty) args = check l ty args
663 check _loc (HsPredTy pred@(HsEqualP _ _))
665 = return $ L spn pred
666 check _loc (HsTyVar t) args | not (isRdrTyVar t)
667 = return (L spn (HsClassP t args))
668 check _loc (HsAppTy l r) args = checkl l (r:args)
669 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
670 check _loc (HsParTy t) args = checkl t args
671 check loc _ _ = parseError loc
672 "malformed class assertion"
674 ---------------------------------------------------------------------------
675 -- Checking statements in a do-expression
676 -- We parse do { e1 ; e2 ; }
677 -- as [ExprStmt e1, ExprStmt e2]
678 -- checkDo (a) checks that the last thing is an ExprStmt
679 -- (b) returns it separately
680 -- same comments apply for mdo as well
682 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
684 checkDo = checkDoMDo "a " "'do'"
685 checkMDo = checkDoMDo "an " "'mdo'"
687 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
688 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
689 checkDoMDo pre nm _ ss = do
692 check [] = panic "RdrHsSyn:checkDoMDo"
693 check [L _ (ExprStmt e _ _)] = return ([], e)
694 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
695 " construct must be an expression")
700 -- -------------------------------------------------------------------------
701 -- Checking Patterns.
703 -- We parse patterns as expressions and check for valid patterns below,
704 -- converting the expression into a pattern at the same time.
706 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
707 checkPattern e = checkLPat e
709 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
710 checkPatterns es = mapM checkPattern es
712 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
713 checkLPat e@(L l _) = checkPat l e []
715 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
716 checkPat loc (L l (HsVar c)) args
717 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
718 checkPat loc e args -- OK to let this happen even if bang-patterns
719 -- are not enabled, because there is no valid
720 -- non-bang-pattern parse of (C ! e)
721 | Just (e', args') <- splitBang e
722 = do { args'' <- checkPatterns args'
723 ; checkPat loc e' (args'' ++ args) }
724 checkPat loc (L _ (HsApp f x)) args
725 = do { x <- checkLPat x; checkPat loc f (x:args) }
726 checkPat loc (L _ e) []
727 = do { pState <- getPState
728 ; p <- checkAPat (dflags pState) loc e
733 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
734 checkAPat dynflags loc e = case e of
735 EWildPat -> return (WildPat placeHolderType)
736 HsVar x -> return (VarPat x)
737 HsLit l -> return (LitPat l)
739 -- Overloaded numeric patterns (e.g. f 0 x = x)
740 -- Negation is recorded separately, so that the literal is zero or +ve
741 -- NB. Negative *primitive* literals are already handled by the lexer
742 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
743 NegApp (L _ (HsOverLit pos_lit)) _
744 -> return (mkNPat pos_lit (Just noSyntaxExpr))
746 SectionR (L _ (HsVar bang)) e -- (! x)
748 -> do { bang_on <- extension bangPatEnabled
749 ; if bang_on then checkLPat e >>= (return . BangPat)
750 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
752 ELazyPat e -> checkLPat e >>= (return . LazyPat)
753 EAsPat n e -> checkLPat e >>= (return . AsPat n)
754 -- view pattern is well-formed if the pattern is
755 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
756 ExprWithTySig e t -> do e <- checkLPat e
757 -- Pattern signatures are parsed as sigtypes,
758 -- but they aren't explicit forall points. Hence
759 -- we have to remove the implicit forall here.
761 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
763 return (SigPatIn e t')
766 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
767 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
768 | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
769 -> return (mkNPlusKPat (L nloc n) lit)
771 OpApp l op _fix r -> do l <- checkLPat l
774 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
775 -> return (ConPatIn (L cl c) (InfixCon l r))
778 HsPar e -> checkLPat e >>= (return . ParPat)
779 ExplicitList _ es -> do ps <- mapM checkLPat es
780 return (ListPat ps placeHolderType)
781 ExplicitPArr _ es -> do ps <- mapM checkLPat es
782 return (PArrPat ps placeHolderType)
785 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
786 return (TuplePat ps b placeHolderType)
787 | otherwise -> parseError loc "Illegal tuple section in pattern"
789 RecordCon c _ (HsRecFields fs dd)
790 -> do fs <- mapM checkPatField fs
791 return (ConPatIn c (RecCon (HsRecFields fs dd)))
792 HsQuasiQuoteE q -> return (QuasiQuotePat q)
794 HsType ty -> return (TypePat ty)
797 placeHolderPunRhs :: HsExpr RdrName
798 -- The RHS of a punned record field will be filled in by the renamer
799 -- It's better not to make it an error, in case we want to print it when debugging
800 placeHolderPunRhs = HsVar pun_RDR
802 plus_RDR, bang_RDR, pun_RDR :: RdrName
803 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
804 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
805 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
807 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
808 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
809 ; return (fld { hsRecFieldArg = p }) }
811 patFail :: SrcSpan -> P a
812 patFail loc = parseError loc "Parse error in pattern"
815 ---------------------------------------------------------------------------
816 -- Check Equation Syntax
818 checkValDef :: LHsExpr RdrName
819 -> Maybe (LHsType RdrName)
820 -> Located (GRHSs RdrName)
821 -> P (HsBind RdrName)
823 checkValDef lhs (Just sig) grhss
824 -- x :: ty = rhs parses as a *pattern* binding
825 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
827 checkValDef lhs opt_sig grhss
828 = do { mb_fun <- isFunLhs lhs
830 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
831 fun is_infix pats opt_sig grhss
832 Nothing -> checkPatBind lhs grhss }
834 checkFunBind :: SrcSpan
838 -> Maybe (LHsType RdrName)
839 -> Located (GRHSs RdrName)
840 -> P (HsBind RdrName)
841 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
842 = do ps <- checkPatterns pats
843 let match_span = combineSrcSpans lhs_loc rhs_span
844 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
845 -- The span of the match covers the entire equation.
846 -- That isn't quite right, but it'll do for now.
848 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
849 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
850 makeFunBind fn is_infix ms
851 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
852 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
854 checkPatBind :: LHsExpr RdrName
855 -> Located (GRHSs RdrName)
856 -> P (HsBind RdrName)
857 checkPatBind lhs (L _ grhss)
858 = do { lhs <- checkPattern lhs
859 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
865 checkValSig (L l (HsVar v)) ty
866 | isUnqual v && not (isDataOcc (rdrNameOcc v))
867 = return (TypeSig (L l v) ty)
868 checkValSig (L l _) _
869 = parseError l "Invalid type signature"
874 -- The parser left-associates, so there should
875 -- not be any OpApps inside the e's
876 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
877 -- Splits (f ! g a b) into (f, [(! g), a, b])
878 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
879 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
881 (arg1,argns) = split_bang r_arg []
882 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
883 split_bang e es = (e,es)
884 splitBang _ = Nothing
886 isFunLhs :: LHsExpr RdrName
887 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
888 -- A variable binding is parsed as a FunBind.
889 -- Just (fun, is_infix, arg_pats) if e is a function LHS
891 -- The whole LHS is parsed as a single expression.
892 -- Any infix operators on the LHS will parse left-associatively
894 -- will parse (rather strangely) as
896 -- It's up to isFunLhs to sort out the mess
902 go (L loc (HsVar f)) es
903 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
904 go (L _ (HsApp f e)) es = go f (e:es)
905 go (L _ (HsPar e)) es@(_:_) = go e es
907 -- For infix function defns, there should be only one infix *function*
908 -- (though there may be infix *datacons* involved too). So we don't
909 -- need fixity info to figure out which function is being defined.
910 -- a `K1` b `op` c `K2` d
912 -- (a `K1` b) `op` (c `K2` d)
913 -- The renamer checks later that the precedences would yield such a parse.
915 -- There is a complication to deal with bang patterns.
917 -- ToDo: what about this?
918 -- x + 1 `op` y = ...
920 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
921 | Just (e',es') <- splitBang e
922 = do { bang_on <- extension bangPatEnabled
923 ; if bang_on then go e' (es' ++ es)
924 else return (Just (L loc' op, True, (l:r:es))) }
925 -- No bangs; behave just like the next case
926 | not (isRdrDataCon op) -- We have found the function!
927 = return (Just (L loc' op, True, (l:r:es)))
928 | otherwise -- Infix data con; keep going
929 = do { mb_l <- go l es
931 Just (op', True, j : k : es')
932 -> return (Just (op', True, j : op_app : es'))
934 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
935 _ -> return Nothing }
936 go _ _ = return Nothing
938 ---------------------------------------------------------------------------
939 -- Miscellaneous utilities
941 checkPrecP :: Located Int -> P Int
943 | 0 <= i && i <= maxPrecedence = return i
944 | otherwise = parseError l "Precedence out of range"
949 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
950 -> P (HsExpr RdrName)
952 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
953 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
954 mkRecConstrOrUpdate exp loc (fs,dd)
955 | null fs = parseError loc "Empty record update"
956 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
958 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
959 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
960 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
962 mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
963 -- The Maybe is because the user can omit the activation spec (and usually does)
964 mkInlinePragma mb_act match_info inl
965 = InlinePragma { inl_inline = inl
967 , inl_rule = match_info }
971 Nothing | inl -> AlwaysActive
972 | otherwise -> NeverActive
973 -- If no specific phase is given then:
974 -- NOINLINE => NeverActive
977 -----------------------------------------------------------------------------
978 -- utilities for foreign declarations
980 -- construct a foreign import declaration
982 mkImport :: CCallConv
984 -> (Located FastString, Located RdrName, LHsType RdrName)
985 -> P (HsDecl RdrName)
986 mkImport cconv safety (L loc entity, v, ty)
987 | cconv == PrimCallConv = do
988 let funcTarget = CFunction (StaticTarget entity)
989 importSpec = CImport PrimCallConv safety nilFS funcTarget
990 return (ForD (ForeignImport v ty importSpec))
992 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
993 Nothing -> parseError loc "Malformed entity string"
994 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
996 -- the string "foo" is ambigous: either a header or a C identifier. The
997 -- C identifier case comes first in the alternatives below, so we pick
999 parseCImport :: CCallConv -> Safety -> FastString -> String
1000 -> Maybe ForeignImport
1001 parseCImport cconv safety nm str =
1002 listToMaybe $ map fst $ filter (null.snd) $
1003 readP_to_S parse str
1006 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
1007 string "wrapper" >> return (mk nilFS CWrapper),
1008 optional (string "static" >> skipSpaces) >>
1009 (mk nilFS <$> cimp nm) +++
1010 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
1013 mk = CImport cconv safety
1015 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
1016 -- pretty much any char (depending on the platform),
1017 -- so just accept any non-space character
1018 id_char c = isAlphaNum c || c == '_'
1020 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1021 +++ ((CFunction . StaticTarget) <$> cid)
1024 (do c <- satisfy (\c -> isAlpha c || c == '_')
1025 cs <- many (satisfy id_char)
1026 return (mkFastString (c:cs)))
1029 -- construct a foreign export declaration
1031 mkExport :: CCallConv
1032 -> (Located FastString, Located RdrName, LHsType RdrName)
1033 -> P (HsDecl RdrName)
1034 mkExport cconv (L _ entity, v, ty) = return $
1035 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1037 entity' | nullFS entity = mkExtName (unLoc v)
1038 | otherwise = entity
1040 -- Supplying the ext_name in a foreign decl is optional; if it
1041 -- isn't there, the Haskell name is assumed. Note that no transformation
1042 -- of the Haskell name is then performed, so if you foreign export (++),
1043 -- it's external name will be "++". Too bad; it's important because we don't
1044 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1046 mkExtName :: RdrName -> CLabelString
1047 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1051 -----------------------------------------------------------------------------
1055 parseError :: SrcSpan -> String -> P a
1056 parseError span s = parseErrorSDoc span (text s)
1058 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1059 parseErrorSDoc span s = failSpanMsgP span s