2 % (c) The University of Glasgow, 1996-2003
4 Functions over HsSyn specialised to RdrName.
9 extractHsRhoRdrTyVars, extractGenericPatTyVars,
12 mkHsIntegral, mkHsFractional, mkHsIsString,
14 mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
15 splitCon, mkInlineSpec,
16 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
21 findSplice, checkDecBrGroup,
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 checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
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, isQual,
57 setRdrNameSpace, showRdrName )
58 import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
59 InlinePragma(..), InlineSpec(..),
60 alwaysInlineSpec, neverInlineSpec )
62 import TysWiredIn ( unitTyCon )
64 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
66 import PrelNames ( forall_tv_RDR )
69 import OrdList ( OrdList, fromOL )
70 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
75 import Control.Applicative ((<$>))
76 import Text.ParserCombinators.ReadP as ReadP
77 import Data.List ( nubBy )
78 import Data.Char ( isAscii, isAlphaNum, isAlpha )
80 #include "HsVersions.h"
84 %************************************************************************
86 \subsection{A few functions over HsSyn at RdrName}
88 %************************************************************************
90 extractHsTyRdrNames finds the free variables of a HsType
91 It's used when making the for-alls explicit.
94 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
95 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
97 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
98 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
100 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
101 -- This one takes the context and tau-part of a
102 -- sigma type and returns their free type variables
103 extractHsRhoRdrTyVars ctxt ty
104 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
106 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
107 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
109 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
110 extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
111 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
112 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
114 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
115 extract_ltys tys acc = foldr extract_lty acc tys
117 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
118 extract_lty (L loc ty) acc
120 HsTyVar tv -> extract_tv loc tv acc
121 HsBangTy _ ty -> extract_lty ty acc
122 HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
123 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
124 HsListTy ty -> extract_lty ty acc
125 HsPArrTy ty -> extract_lty ty 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
132 HsSpliceTy _ -> acc -- Type splices mention no type variables
133 HsKindSig ty _ -> extract_lty ty acc
134 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
135 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
136 extract_lctxt cx (extract_lty ty []))
138 locals = hsLTyVarNames tvs
139 HsDocTy ty _ -> extract_lty ty acc
141 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
142 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
145 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
146 -- Get the type variables out of the type patterns in a bunch of
147 -- possibly-generic bindings in a class declaration
148 extractGenericPatTyVars binds
149 = nubBy eqLocated (foldrBag get [] binds)
151 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
154 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
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 (LHsContext RdrName, LHsType RdrName)
178 -> Located [Located (FunDep RdrName)]
179 -> Located (OrdList (LHsDecl RdrName))
180 -> P (LTyClDecl RdrName)
182 mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
183 = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
184 ; (cls, tparams) <- checkTyClHdr tycl_hdr
185 ; tyvars <- checkTyVars tparams -- Only type vars allowed
187 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
188 tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
189 tcdATs = ats, tcdDocs = docs })) }
193 -> Bool -- True <=> data family instance
194 -> Located (LHsContext RdrName, LHsType RdrName)
196 -> [LConDecl RdrName]
197 -> Maybe [LHsType RdrName]
198 -> P (LTyClDecl RdrName)
199 mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
200 = do { (tc, tparams) <- checkTyClHdr tycl_hdr
202 ; (tyvars, typats) <- checkTParams is_family tparams
203 ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
204 tcdTyVars = tyvars, tcdTyPats = typats,
206 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
208 mkTySynonym :: SrcSpan
209 -> Bool -- True <=> type family instances
210 -> LHsType RdrName -- LHS
211 -> LHsType RdrName -- RHS
212 -> P (LTyClDecl RdrName)
213 mkTySynonym loc is_family lhs rhs
214 = do { (tc, tparams) <- checkTyClHdr lhs
215 ; (tyvars, typats) <- checkTParams is_family tparams
216 ; return (L loc (TySynonym tc tyvars typats rhs)) }
218 mkTyFamily :: SrcSpan
220 -> LHsType RdrName -- LHS
221 -> Maybe Kind -- Optional kind signature
222 -> P (LTyClDecl RdrName)
223 mkTyFamily loc flavour lhs ksig
224 = do { (tc, tparams) <- checkTyClHdr lhs
225 ; tyvars <- checkTyVars tparams
226 ; return (L loc (TyFamily flavour tc tyvars ksig)) }
229 %************************************************************************
231 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
233 %************************************************************************
235 Function definitions are restructured here. Each is assumed to be recursive
236 initially, and non recursive definitions are discovered by the dependency
241 -- | Groups together bindings for a single function
242 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
243 cvTopDecls decls = go (fromOL decls)
245 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
247 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
248 where (L l' b', ds') = getMonoBind (L l b) ds
249 go (d : ds) = d : go ds
251 -- Declaration list may only contain value bindings and signatures.
252 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
254 = case cvBindsAndSigs binding of
255 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
258 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
259 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
260 -- Input decls contain just value bindings and signatures
261 -- and in case of class or instance declarations also
262 -- associated type declarations. They might also contain Haddock comments.
263 cvBindsAndSigs fb = go (fromOL fb)
265 go [] = (emptyBag, [], [], [])
266 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
267 where (bs, ss, ts, docs) = go ds
268 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
269 where (b', ds') = getMonoBind (L l b) ds
270 (bs, ss, ts, docs) = go ds'
271 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
272 where (bs, ss, ts, docs) = go ds
273 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
274 where (bs, ss, ts, docs) = go ds
275 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
277 -----------------------------------------------------------------------------
278 -- Group function bindings into equation groups
280 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
281 -> (LHsBind RdrName, [LHsDecl RdrName])
282 -- Suppose (b',ds') = getMonoBind b ds
283 -- ds is a list of parsed bindings
284 -- b is a MonoBinds that has just been read off the front
286 -- Then b' is the result of grouping more equations from ds that
287 -- belong with b into a single MonoBinds, and ds' is the depleted
288 -- list of parsed bindings.
290 -- All Haddock comments between equations inside the group are
293 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
295 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
296 fun_matches = MatchGroup mtchs1 _ })) binds
298 = go is_infix1 mtchs1 loc1 binds []
300 go is_infix mtchs loc
301 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
302 fun_matches = MatchGroup mtchs2 _ })) : binds) _
303 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
304 (combineSrcSpans loc loc2) binds []
305 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
306 = let doc_decls' = doc_decl : doc_decls
307 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
308 go is_infix mtchs loc binds doc_decls
309 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
310 -- Reverse the final matches, to get it back in the right order
311 -- Do the same thing with the trailing doc comments
313 getMonoBind bind binds = (bind, binds)
315 has_args :: [LMatch RdrName] -> Bool
316 has_args [] = panic "RdrHsSyn:has_args"
317 has_args ((L _ (Match args _ _)) : _) = not (null args)
318 -- Don't group together FunBinds if they have
319 -- no arguments. This is necessary now that variable bindings
320 -- with no arguments are now treated as FunBinds rather
321 -- than pattern bindings (tests/rename/should_fail/rnfail002).
325 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
326 findSplice ds = addl emptyRdrGroup ds
328 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
329 -- Turn the body of a [d| ... |] into a HsGroup
330 -- There should be no splices in the "..."
331 checkDecBrGroup decls
332 = case addl emptyRdrGroup decls of
333 (group, Nothing) -> return group
334 (_, Just (SpliceDecl (L loc _), _)) ->
335 parseError loc "Declaration splices are not permitted inside declaration brackets"
336 -- Why not? See Section 7.3 of the TH paper.
338 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
339 -- This stuff reverses the declarations (again) but it doesn't matter
342 addl gp [] = (gp, Nothing)
343 addl gp (L l d : ds) = add gp l d ds
346 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
347 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
349 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
351 -- Class declarations: pull out the fixity signatures to the top
352 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
355 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
356 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
358 addl (gp { hs_tyclds = L l d : ts }) ds
360 -- Signatures: fixity sigs go a different place than all others
361 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
362 = addl (gp {hs_fixds = L l f : ts}) ds
363 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
364 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
366 -- Value declarations: use add_bind
367 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
368 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
370 -- The rest are routine
371 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
372 = addl (gp { hs_instds = L l d : ts }) ds
373 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
374 = addl (gp { hs_derivds = L l d : ts }) ds
375 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
376 = addl (gp { hs_defds = L l d : ts }) ds
377 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
378 = addl (gp { hs_fords = L l d : ts }) ds
379 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
380 = addl (gp { hs_warnds = L l d : ts }) ds
381 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
382 = addl (gp { hs_annds = L l d : ts }) ds
383 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
384 = addl (gp { hs_ruleds = L l d : ts }) ds
387 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
389 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
390 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
391 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
393 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
394 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
395 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
398 %************************************************************************
400 \subsection[PrefixToHS-utils]{Utilities for conversion}
402 %************************************************************************
406 -----------------------------------------------------------------------------
409 -- When parsing data declarations, we sometimes inadvertently parse
410 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
411 -- This function splits up the type application, adds any pending
412 -- arguments, and converts the type constructor back into a data constructor.
414 splitCon :: LHsType RdrName
415 -> P (Located RdrName, HsConDeclDetails RdrName)
416 -- This gets given a "type" that should look like
418 -- or C { x::Int, y::Bool }
419 -- and returns the pieces
423 split (L _ (HsAppTy t u)) ts = split t (u : ts)
424 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
425 return (data_con, mk_rest ts)
426 split (L l _) _ = parseError l "parse error in data/newtype declaration"
428 mk_rest [L _ (HsRecTy flds)] = RecCon flds
429 mk_rest ts = PrefixCon ts
431 mkDeprecatedGadtRecordDecl :: SrcSpan
433 -> [ConDeclField RdrName]
435 -> P (LConDecl RdrName)
436 -- This one uses the deprecated syntax
437 -- C { x,y ::Int } :: T a b
438 -- We give it a RecCon details right away
439 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
440 = do { data_con <- tyConToDataCon con_loc con
441 ; return (L loc (ConDecl { con_old_rec = True
442 , con_name = data_con
443 , con_explicit = Implicit
446 , con_details = RecCon flds
447 , con_res = ResTyGADT res_ty
448 , con_doc = Nothing })) }
450 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
451 -> LHsContext RdrName -> HsConDeclDetails RdrName
454 mkSimpleConDecl name qvars cxt details
455 = ConDecl { con_old_rec = False
457 , con_explicit = Explicit
460 , con_details = details
462 , con_doc = Nothing }
464 mkGadtDecl :: [Located RdrName]
465 -> LHsType RdrName -- Always a HsForAllTy
467 -- We allow C,D :: ty
468 -- and expand it as if it had been
470 -- (Just like type signatures in general.)
471 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
472 = [mk_gadt_con name | name <- names]
474 (details, res_ty) -- See Note [Sorting out the result type]
476 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
477 _other -> (PrefixCon [], tau)
480 = ConDecl { con_old_rec = False
485 , con_details = details
486 , con_res = ResTyGADT res_ty
487 , con_doc = Nothing }
488 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
490 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
491 tyConToDataCon loc tc
492 | isTcOcc (rdrNameOcc tc)
493 = return (L loc (setRdrNameSpace tc srcDataName))
495 = parseErrorSDoc loc (msg $$ extra)
497 msg = text "Not a data constructor:" <+> quotes (ppr tc)
498 extra | tc == forall_tv_RDR
499 = text "Perhaps you intended to use -XExistentialQuantification"
503 Note [Sorting out the result type]
504 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
505 In a GADT declaration which is not a record, we put the whole constr
506 type into the ResTyGADT for now; the renamer will unravel it once it
507 has sorted out operator fixities. Consider for example
508 C :: a :*: b -> a :*: b -> a :+: b
509 Initially this type will parse as
510 a :*: (b -> (a :*: (b -> (a :+: b))))
512 so it's hard to split up the arguments until we've done the precedence
513 resolution (in the renamer) On the other hand, for a record
514 { x,y :: Int } -> a :*: b
515 there is no doubt. AND we need to sort records out so that
516 we can bring x,y into scope. So:
517 * For PrefixCon we keep all the args in the ResTyGADT
518 * For RecCon we do not
521 ----------------------------------------------------------------------------
522 -- Various Syntactic Checks
524 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
525 checkInstType (L l t)
527 HsForAllTy exp tvs ctxt ty -> do
528 dict_ty <- checkDictTy ty
529 return (L l (HsForAllTy exp tvs ctxt dict_ty))
531 HsParTy ty -> checkInstType ty
533 ty -> do dict_ty <- checkDictTy (L l ty)
534 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
536 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
537 checkDictTy (L spn ty) = check ty []
539 check (HsTyVar t) args | not (isRdrTyVar t)
540 = return (L spn (HsPredTy (HsClassP t args)))
541 check (HsAppTy l r) args = check (unLoc l) (r:args)
542 check (HsParTy t) args = check (unLoc t) args
543 check _ _ = parseError spn "Malformed instance header"
545 checkTParams :: Bool -- Type/data family
547 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
548 -- checkTParams checks the type parameters of a data/newtype declaration
549 -- There are two cases:
551 -- a) Vanilla data/newtype decl. In that case
552 -- - the type parameters should all be type variables
553 -- - they may have a kind annotation
555 -- b) Family data/newtype decl. In that case
556 -- - The type parameters may be arbitrary types
557 -- - We find the type-varaible binders by find the
558 -- free type vars of those types
559 -- - We make them all kind-sig-free binders (UserTyVar)
560 -- If there are kind sigs in the type parameters, they
561 -- will fix the binder's kind when we kind-check the
563 checkTParams is_family tparams
564 | not is_family -- Vanilla case (a)
565 = do { tyvars <- checkTyVars tparams
566 ; return (tyvars, Nothing) }
567 | otherwise -- Family case (b)
568 = do { let tyvars = [L l (UserTyVar tv)
569 | L l tv <- extractHsTysRdrTyVars tparams]
570 ; return (tyvars, Just tparams) }
572 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
573 -- Check whether the given list of type parameters are all type variables
574 -- (possibly with a kind signature). If the second argument is `False',
575 -- only type variables are allowed and we raise an error on encountering a
576 -- non-variable; otherwise, we allow non-variable arguments and return the
577 -- entire list of parameters.
578 checkTyVars tparms = mapM chk tparms
580 -- Check that the name space is correct!
581 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
582 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
583 chk (L l (HsTyVar tv))
584 | isRdrTyVar tv = return (L l (UserTyVar tv))
586 parseError l "Type found where type variable expected"
588 checkTyClHdr :: LHsType RdrName
589 -> P (Located RdrName, -- the head symbol (type or class name)
590 [LHsType RdrName]) -- parameters of head symbol
591 -- Well-formedness check and decomposition of type and class heads.
592 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
593 -- Int :*: Bool into (:*:, [Int, Bool])
594 -- returning the pieces
598 goL (L l ty) acc = go l ty acc
600 go l (HsTyVar tc) acc
601 | isRdrTc tc = return (L l tc, acc)
603 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
604 | isRdrTc tc = return (ltc, t1:t2:acc)
605 go _ (HsParTy ty) acc = goL ty acc
606 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
607 go l _ _ = parseError l "Malformed head of type or class declaration"
609 -- Check that associated type declarations of a class are all kind signatures.
611 checkKindSigs :: [LTyClDecl RdrName] -> P ()
612 checkKindSigs = mapM_ check
615 | isFamilyDecl tydecl
616 || isSynDecl tydecl = return ()
618 parseError l "Type declaration in a class must be a kind signature or synonym default"
620 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
624 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
625 = do ctx <- mapM checkPred ts
628 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
631 check (HsTyVar t) -- Empty context shows up as a unit type ()
632 | t == getRdrName unitTyCon = return (L l [])
635 = do p <- checkPred (L l t)
639 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
640 -- Watch out.. in ...deriving( Show )... we use checkPred on
641 -- the list of partially applied predicates in the deriving,
642 -- so there can be zero args.
643 checkPred (L spn (HsPredTy (HsIParam n ty)))
644 = return (L spn (HsIParam n ty))
648 checkl (L l ty) args = check l ty args
650 check _loc (HsPredTy pred@(HsEqualP _ _))
652 = return $ L spn pred
653 check _loc (HsTyVar t) args | not (isRdrTyVar t)
654 = return (L spn (HsClassP t args))
655 check _loc (HsAppTy l r) args = checkl l (r:args)
656 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
657 check _loc (HsParTy t) args = checkl t args
658 check loc _ _ = parseError loc
659 "malformed class assertion"
661 ---------------------------------------------------------------------------
662 -- Checking stand-alone deriving declarations
664 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
665 checkDerivDecl d@(L loc _) =
666 do stDerivOn <- extension standaloneDerivingEnabled
667 if stDerivOn then return d
668 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
670 ---------------------------------------------------------------------------
671 -- Checking statements in a do-expression
672 -- We parse do { e1 ; e2 ; }
673 -- as [ExprStmt e1, ExprStmt e2]
674 -- checkDo (a) checks that the last thing is an ExprStmt
675 -- (b) returns it separately
676 -- same comments apply for mdo as well
678 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
680 checkDo = checkDoMDo "a " "'do'"
681 checkMDo = checkDoMDo "an " "'mdo'"
683 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
684 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
685 checkDoMDo pre nm _ ss = do
688 check [] = panic "RdrHsSyn:checkDoMDo"
689 check [L _ (ExprStmt e _ _)] = return ([], e)
690 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
691 " construct must be an expression")
696 -- -------------------------------------------------------------------------
697 -- Checking Patterns.
699 -- We parse patterns as expressions and check for valid patterns below,
700 -- converting the expression into a pattern at the same time.
702 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
703 checkPattern e = checkLPat e
705 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
706 checkPatterns es = mapM checkPattern es
708 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
709 checkLPat e@(L l _) = checkPat l e []
711 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
712 checkPat loc (L l (HsVar c)) args
713 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
714 checkPat loc e args -- OK to let this happen even if bang-patterns
715 -- are not enabled, because there is no valid
716 -- non-bang-pattern parse of (C ! e)
717 | Just (e', args') <- splitBang e
718 = do { args'' <- checkPatterns args'
719 ; checkPat loc e' (args'' ++ args) }
720 checkPat loc (L _ (HsApp f x)) args
721 = do { x <- checkLPat x; checkPat loc f (x:args) }
722 checkPat loc (L _ e) []
723 = do { pState <- getPState
724 ; p <- checkAPat (dflags pState) loc e
729 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
730 checkAPat dynflags loc e = case e of
731 EWildPat -> return (WildPat placeHolderType)
732 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
734 | otherwise -> return (VarPat x)
735 HsLit l -> return (LitPat l)
737 -- Overloaded numeric patterns (e.g. f 0 x = x)
738 -- Negation is recorded separately, so that the literal is zero or +ve
739 -- NB. Negative *primitive* literals are already handled by the lexer
740 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
741 NegApp (L _ (HsOverLit pos_lit)) _
742 -> return (mkNPat pos_lit (Just noSyntaxExpr))
744 SectionR (L _ (HsVar bang)) e -- (! x)
746 -> do { bang_on <- extension bangPatEnabled
747 ; if bang_on then checkLPat e >>= (return . BangPat)
748 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
750 ELazyPat e -> checkLPat e >>= (return . LazyPat)
751 EAsPat n e -> checkLPat e >>= (return . AsPat n)
752 -- view pattern is well-formed if the pattern is
753 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
754 ExprWithTySig e t -> do e <- checkLPat e
755 -- Pattern signatures are parsed as sigtypes,
756 -- but they aren't explicit forall points. Hence
757 -- we have to remove the implicit forall here.
759 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
761 return (SigPatIn e t')
764 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
765 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
766 | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
767 -> return (mkNPlusKPat (L nloc n) lit)
769 OpApp l op _fix r -> do l <- checkLPat l
772 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
773 -> return (ConPatIn (L cl c) (InfixCon l r))
776 HsPar e -> checkLPat e >>= (return . ParPat)
777 ExplicitList _ es -> do ps <- mapM checkLPat es
778 return (ListPat ps placeHolderType)
779 ExplicitPArr _ es -> do ps <- mapM checkLPat es
780 return (PArrPat ps placeHolderType)
783 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
784 return (TuplePat ps b placeHolderType)
785 | otherwise -> parseError loc "Illegal tuple section in pattern"
787 RecordCon c _ (HsRecFields fs dd)
788 -> do fs <- mapM checkPatField fs
789 return (ConPatIn c (RecCon (HsRecFields fs dd)))
790 HsQuasiQuoteE q -> return (QuasiQuotePat q)
792 HsType ty -> return (TypePat ty)
795 plus_RDR, bang_RDR :: RdrName
796 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
797 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
799 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
800 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
801 ; return (fld { hsRecFieldArg = p }) }
803 patFail :: SrcSpan -> P a
804 patFail loc = parseError loc "Parse error in pattern"
807 ---------------------------------------------------------------------------
808 -- Check Equation Syntax
810 checkValDef :: LHsExpr RdrName
811 -> Maybe (LHsType RdrName)
812 -> Located (GRHSs RdrName)
813 -> P (HsBind RdrName)
815 checkValDef lhs (Just sig) grhss
816 -- x :: ty = rhs parses as a *pattern* binding
817 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
819 checkValDef lhs opt_sig grhss
820 = do { mb_fun <- isFunLhs lhs
822 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
823 fun is_infix pats opt_sig grhss
824 Nothing -> checkPatBind lhs grhss }
826 checkFunBind :: SrcSpan
830 -> Maybe (LHsType RdrName)
831 -> Located (GRHSs RdrName)
832 -> P (HsBind RdrName)
833 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
835 = parseErrorSDoc (getLoc fun)
836 (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
838 = do ps <- checkPatterns pats
839 let match_span = combineSrcSpans lhs_loc rhs_span
840 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
841 -- The span of the match covers the entire equation.
842 -- That isn't quite right, but it'll do for now.
844 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
845 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
846 makeFunBind fn is_infix ms
847 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
848 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
850 checkPatBind :: LHsExpr RdrName
851 -> Located (GRHSs RdrName)
852 -> P (HsBind RdrName)
853 checkPatBind lhs (L _ grhss)
854 = do { lhs <- checkPattern lhs
855 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
861 checkValSig (L l (HsVar v)) ty
862 | isUnqual v && not (isDataOcc (rdrNameOcc v))
863 = return (TypeSig (L l v) ty)
864 checkValSig (L l _) _
865 = parseError l "Invalid type signature"
870 -- The parser left-associates, so there should
871 -- not be any OpApps inside the e's
872 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
873 -- Splits (f ! g a b) into (f, [(! g), a, b])
874 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
875 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
877 (arg1,argns) = split_bang r_arg []
878 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
879 split_bang e es = (e,es)
880 splitBang _ = Nothing
882 isFunLhs :: LHsExpr RdrName
883 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
884 -- A variable binding is parsed as a FunBind.
885 -- Just (fun, is_infix, arg_pats) if e is a function LHS
887 -- The whole LHS is parsed as a single expression.
888 -- Any infix operators on the LHS will parse left-associatively
890 -- will parse (rather strangely) as
892 -- It's up to isFunLhs to sort out the mess
898 go (L loc (HsVar f)) es
899 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
900 go (L _ (HsApp f e)) es = go f (e:es)
901 go (L _ (HsPar e)) es@(_:_) = go e es
903 -- For infix function defns, there should be only one infix *function*
904 -- (though there may be infix *datacons* involved too). So we don't
905 -- need fixity info to figure out which function is being defined.
906 -- a `K1` b `op` c `K2` d
908 -- (a `K1` b) `op` (c `K2` d)
909 -- The renamer checks later that the precedences would yield such a parse.
911 -- There is a complication to deal with bang patterns.
913 -- ToDo: what about this?
914 -- x + 1 `op` y = ...
916 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
917 | Just (e',es') <- splitBang e
918 = do { bang_on <- extension bangPatEnabled
919 ; if bang_on then go e' (es' ++ es)
920 else return (Just (L loc' op, True, (l:r:es))) }
921 -- No bangs; behave just like the next case
922 | not (isRdrDataCon op) -- We have found the function!
923 = return (Just (L loc' op, True, (l:r:es)))
924 | otherwise -- Infix data con; keep going
925 = do { mb_l <- go l es
927 Just (op', True, j : k : es')
928 -> return (Just (op', True, j : op_app : es'))
930 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
931 _ -> return Nothing }
932 go _ _ = return Nothing
934 ---------------------------------------------------------------------------
935 -- Miscellaneous utilities
937 checkPrecP :: Located Int -> P Int
939 | 0 <= i && i <= maxPrecedence = return i
940 | otherwise = parseError l "Precedence out of range"
945 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
946 -> P (HsExpr RdrName)
948 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
949 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
950 mkRecConstrOrUpdate exp loc (fs,dd)
951 | null fs = parseError loc "Empty record update"
952 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
954 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
955 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
956 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
958 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
959 -- The Maybe is becuase the user can omit the activation spec (and usually does)
960 mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
962 mkInlineSpec Nothing match_info False = neverInlineSpec match_info
964 mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
966 -----------------------------------------------------------------------------
967 -- utilities for foreign declarations
969 -- construct a foreign import declaration
971 mkImport :: CCallConv
973 -> (Located FastString, Located RdrName, LHsType RdrName)
974 -> P (HsDecl RdrName)
975 mkImport cconv safety (L loc entity, v, ty)
976 | cconv == PrimCallConv = do
977 let funcTarget = CFunction (StaticTarget entity)
978 importSpec = CImport PrimCallConv safety nilFS funcTarget
979 return (ForD (ForeignImport v ty importSpec))
981 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
982 Nothing -> parseError loc "Malformed entity string"
983 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
985 -- the string "foo" is ambigous: either a header or a C identifier. The
986 -- C identifier case comes first in the alternatives below, so we pick
988 parseCImport :: CCallConv -> Safety -> FastString -> String
989 -> Maybe ForeignImport
990 parseCImport cconv safety nm str =
991 listToMaybe $ map fst $ filter (null.snd) $
995 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
996 string "wrapper" >> return (mk nilFS CWrapper),
997 optional (string "static" >> skipSpaces) >>
998 (mk nilFS <$> cimp nm) +++
999 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
1002 mk = CImport cconv safety
1004 hdr_char c = isAscii c && (isAlphaNum c || c `elem` "._")
1005 id_char c = isAlphaNum c || c == '_'
1007 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1008 +++ ((CFunction . StaticTarget) <$> cid)
1011 (do c <- satisfy (\c -> isAlpha c || c == '_')
1012 cs <- many (satisfy id_char)
1013 return (mkFastString (c:cs)))
1016 -- construct a foreign export declaration
1018 mkExport :: CCallConv
1019 -> (Located FastString, Located RdrName, LHsType RdrName)
1020 -> P (HsDecl RdrName)
1021 mkExport cconv (L _ entity, v, ty) = return $
1022 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1024 entity' | nullFS entity = mkExtName (unLoc v)
1025 | otherwise = entity
1027 -- Supplying the ext_name in a foreign decl is optional; if it
1028 -- isn't there, the Haskell name is assumed. Note that no transformation
1029 -- of the Haskell name is then performed, so if you foreign export (++),
1030 -- it's external name will be "++". Too bad; it's important because we don't
1031 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1033 mkExtName :: RdrName -> CLabelString
1034 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1038 -----------------------------------------------------------------------------
1042 parseError :: SrcSpan -> String -> P a
1043 parseError span s = parseErrorSDoc span (text s)
1045 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1046 parseErrorSDoc span s = failSpanMsgP span s