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, setRdrNameSpace )
57 import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
58 InlinePragma(..), InlineSpec(..),
59 alwaysInlineSpec, neverInlineSpec )
61 import TysWiredIn ( unitTyCon )
63 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
65 import PrelNames ( forall_tv_RDR )
68 import OrdList ( OrdList, fromOL )
69 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
74 import Control.Applicative ((<$>))
75 import Text.ParserCombinators.ReadP as ReadP
76 import Data.List ( nubBy )
77 import Data.Char ( isAscii, isAlphaNum, isAlpha )
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 HsTupleTy _ tys -> extract_ltys tys acc
126 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
127 HsPredTy p -> extract_pred p acc
128 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
129 HsParTy ty -> extract_lty ty acc
131 HsSpliceTy _ -> 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)) }
228 %************************************************************************
230 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
232 %************************************************************************
234 Function definitions are restructured here. Each is assumed to be recursive
235 initially, and non recursive definitions are discovered by the dependency
240 -- | Groups together bindings for a single function
241 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
242 cvTopDecls decls = go (fromOL decls)
244 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
246 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
247 where (L l' b', ds') = getMonoBind (L l b) ds
248 go (d : ds) = d : go ds
250 -- Declaration list may only contain value bindings and signatures.
251 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
253 = case cvBindsAndSigs binding of
254 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
257 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
258 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
259 -- Input decls contain just value bindings and signatures
260 -- and in case of class or instance declarations also
261 -- associated type declarations. They might also contain Haddock comments.
262 cvBindsAndSigs fb = go (fromOL fb)
264 go [] = (emptyBag, [], [], [])
265 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
266 where (bs, ss, ts, docs) = go ds
267 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
268 where (b', ds') = getMonoBind (L l b) ds
269 (bs, ss, ts, docs) = go ds'
270 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
271 where (bs, ss, ts, docs) = go ds
272 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
273 where (bs, ss, ts, docs) = go ds
274 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
276 -----------------------------------------------------------------------------
277 -- Group function bindings into equation groups
279 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
280 -> (LHsBind RdrName, [LHsDecl RdrName])
281 -- Suppose (b',ds') = getMonoBind b ds
282 -- ds is a list of parsed bindings
283 -- b is a MonoBinds that has just been read off the front
285 -- Then b' is the result of grouping more equations from ds that
286 -- belong with b into a single MonoBinds, and ds' is the depleted
287 -- list of parsed bindings.
289 -- All Haddock comments between equations inside the group are
292 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
294 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
295 fun_matches = MatchGroup mtchs1 _ })) binds
297 = go is_infix1 mtchs1 loc1 binds []
299 go is_infix mtchs loc
300 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
301 fun_matches = MatchGroup mtchs2 _ })) : binds) _
302 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
303 (combineSrcSpans loc loc2) binds []
304 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
305 = let doc_decls' = doc_decl : doc_decls
306 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
307 go is_infix mtchs loc binds doc_decls
308 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
309 -- Reverse the final matches, to get it back in the right order
310 -- Do the same thing with the trailing doc comments
312 getMonoBind bind binds = (bind, binds)
314 has_args :: [LMatch RdrName] -> Bool
315 has_args [] = panic "RdrHsSyn:has_args"
316 has_args ((L _ (Match args _ _)) : _) = not (null args)
317 -- Don't group together FunBinds if they have
318 -- no arguments. This is necessary now that variable bindings
319 -- with no arguments are now treated as FunBinds rather
320 -- than pattern bindings (tests/rename/should_fail/rnfail002).
324 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
325 findSplice ds = addl emptyRdrGroup ds
327 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
328 -- Turn the body of a [d| ... |] into a HsGroup
329 -- There should be no splices in the "..."
330 checkDecBrGroup decls
331 = case addl emptyRdrGroup decls of
332 (group, Nothing) -> return group
333 (_, Just (SpliceDecl (L loc _), _)) ->
334 parseError loc "Declaration splices are not permitted inside declaration brackets"
335 -- Why not? See Section 7.3 of the TH paper.
337 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
338 -- This stuff reverses the declarations (again) but it doesn't matter
341 addl gp [] = (gp, Nothing)
342 addl gp (L l d : ds) = add gp l d ds
345 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
346 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
348 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
350 -- Class declarations: pull out the fixity signatures to the top
351 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
354 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
355 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
357 addl (gp { hs_tyclds = L l d : ts }) ds
359 -- Signatures: fixity sigs go a different place than all others
360 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
361 = addl (gp {hs_fixds = L l f : ts}) ds
362 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
363 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
365 -- Value declarations: use add_bind
366 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
367 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
369 -- The rest are routine
370 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
371 = addl (gp { hs_instds = L l d : ts }) ds
372 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
373 = addl (gp { hs_derivds = L l d : ts }) ds
374 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
375 = addl (gp { hs_defds = L l d : ts }) ds
376 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
377 = addl (gp { hs_fords = L l d : ts }) ds
378 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
379 = addl (gp { hs_warnds = L l d : ts }) ds
380 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
381 = addl (gp { hs_annds = L l d : ts }) ds
382 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
383 = addl (gp { hs_ruleds = L l d : ts }) ds
386 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
388 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
389 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
390 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
392 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
393 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
394 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
397 %************************************************************************
399 \subsection[PrefixToHS-utils]{Utilities for conversion}
401 %************************************************************************
405 -----------------------------------------------------------------------------
408 -- When parsing data declarations, we sometimes inadvertently parse
409 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
410 -- This function splits up the type application, adds any pending
411 -- arguments, and converts the type constructor back into a data constructor.
413 splitCon :: LHsType RdrName
414 -> P (Located RdrName, HsConDeclDetails RdrName)
415 -- This gets given a "type" that should look like
417 -- or C { x::Int, y::Bool }
418 -- and returns the pieces
422 split (L _ (HsAppTy t u)) ts = split t (u : ts)
423 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
424 return (data_con, mk_rest ts)
425 split (L l _) _ = parseError l "parse error in data/newtype declaration"
427 mk_rest [L _ (HsRecTy flds)] = RecCon flds
428 mk_rest ts = PrefixCon ts
430 mkDeprecatedGadtRecordDecl :: SrcSpan
432 -> [ConDeclField RdrName]
434 -> P (LConDecl RdrName)
435 -- This one uses the deprecated syntax
436 -- C { x,y ::Int } :: T a b
437 -- We give it a RecCon details right away
438 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
439 = do { data_con <- tyConToDataCon con_loc con
440 ; return (L loc (ConDecl { con_old_rec = True
441 , con_name = data_con
442 , con_explicit = Implicit
445 , con_details = RecCon flds
446 , con_res = ResTyGADT res_ty
447 , con_doc = Nothing })) }
449 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
450 -> LHsContext RdrName -> HsConDeclDetails RdrName
453 mkSimpleConDecl name qvars cxt details
454 = ConDecl { con_old_rec = False
456 , con_explicit = Explicit
459 , con_details = details
461 , con_doc = Nothing }
463 mkGadtDecl :: [Located RdrName]
464 -> LHsType RdrName -- Always a HsForAllTy
466 -- We allow C,D :: ty
467 -- and expand it as if it had been
469 -- (Just like type signatures in general.)
470 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
471 = [mk_gadt_con name | name <- names]
473 (details, res_ty) -- See Note [Sorting out the result type]
475 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
476 _other -> (PrefixCon [], tau)
479 = ConDecl { con_old_rec = False
484 , con_details = details
485 , con_res = ResTyGADT res_ty
486 , con_doc = Nothing }
487 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
489 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
490 tyConToDataCon loc tc
491 | isTcOcc (rdrNameOcc tc)
492 = return (L loc (setRdrNameSpace tc srcDataName))
494 = parseErrorSDoc loc (msg $$ extra)
496 msg = text "Not a data constructor:" <+> quotes (ppr tc)
497 extra | tc == forall_tv_RDR
498 = text "Perhaps you intended to use -XExistentialQuantification"
502 Note [Sorting out the result type]
503 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
504 In a GADT declaration which is not a record, we put the whole constr
505 type into the ResTyGADT for now; the renamer will unravel it once it
506 has sorted out operator fixities. Consider for example
507 C :: a :*: b -> a :*: b -> a :+: b
508 Initially this type will parse as
509 a :*: (b -> (a :*: (b -> (a :+: b))))
511 so it's hard to split up the arguments until we've done the precedence
512 resolution (in the renamer) On the other hand, for a record
513 { x,y :: Int } -> a :*: b
514 there is no doubt. AND we need to sort records out so that
515 we can bring x,y into scope. So:
516 * For PrefixCon we keep all the args in the ResTyGADT
517 * For RecCon we do not
520 ----------------------------------------------------------------------------
521 -- Various Syntactic Checks
523 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
524 checkInstType (L l t)
526 HsForAllTy exp tvs ctxt ty -> do
527 dict_ty <- checkDictTy ty
528 return (L l (HsForAllTy exp tvs ctxt dict_ty))
530 HsParTy ty -> checkInstType ty
532 ty -> do dict_ty <- checkDictTy (L l ty)
533 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
535 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
536 checkDictTy (L spn ty) = check ty []
538 check (HsTyVar t) args | not (isRdrTyVar t)
539 = return (L spn (HsPredTy (HsClassP t args)))
540 check (HsAppTy l r) args = check (unLoc l) (r:args)
541 check (HsParTy t) args = check (unLoc t) args
542 check _ _ = parseError spn "Malformed instance header"
544 checkTParams :: Bool -- Type/data family
546 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
547 -- checkTParams checks the type parameters of a data/newtype declaration
548 -- There are two cases:
550 -- a) Vanilla data/newtype decl. In that case
551 -- - the type parameters should all be type variables
552 -- - they may have a kind annotation
554 -- b) Family data/newtype decl. In that case
555 -- - The type parameters may be arbitrary types
556 -- - We find the type-varaible binders by find the
557 -- free type vars of those types
558 -- - We make them all kind-sig-free binders (UserTyVar)
559 -- If there are kind sigs in the type parameters, they
560 -- will fix the binder's kind when we kind-check the
562 checkTParams is_family tparams
563 | not is_family -- Vanilla case (a)
564 = do { tyvars <- checkTyVars tparams
565 ; return (tyvars, Nothing) }
566 | otherwise -- Family case (b)
567 = do { let tyvars = [L l (UserTyVar tv)
568 | L l tv <- extractHsTysRdrTyVars tparams]
569 ; return (tyvars, Just tparams) }
571 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
572 -- Check whether the given list of type parameters are all type variables
573 -- (possibly with a kind signature). If the second argument is `False',
574 -- only type variables are allowed and we raise an error on encountering a
575 -- non-variable; otherwise, we allow non-variable arguments and return the
576 -- entire list of parameters.
577 checkTyVars tparms = mapM chk tparms
579 -- Check that the name space is correct!
580 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
581 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
582 chk (L l (HsTyVar tv))
583 | isRdrTyVar tv = return (L l (UserTyVar tv))
585 parseError l "Type found where type variable expected"
587 checkTyClHdr :: LHsType RdrName
588 -> P (Located RdrName, -- the head symbol (type or class name)
589 [LHsType RdrName]) -- parameters of head symbol
590 -- Well-formedness check and decomposition of type and class heads.
591 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
592 -- Int :*: Bool into (:*:, [Int, Bool])
593 -- returning the pieces
597 goL (L l ty) acc = go l ty acc
599 go l (HsTyVar tc) acc
600 | isRdrTc tc = return (L l tc, acc)
602 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
603 | isRdrTc tc = return (ltc, t1:t2:acc)
604 go _ (HsParTy ty) acc = goL ty acc
605 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
606 go l _ _ = parseError l "Malformed head of type or class declaration"
608 -- Check that associated type declarations of a class are all kind signatures.
610 checkKindSigs :: [LTyClDecl RdrName] -> P ()
611 checkKindSigs = mapM_ check
614 | isFamilyDecl tydecl
615 || isSynDecl tydecl = return ()
617 parseError l "Type declaration in a class must be a kind signature or synonym default"
619 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
623 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
624 = do ctx <- mapM checkPred ts
627 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
630 check (HsTyVar t) -- Empty context shows up as a unit type ()
631 | t == getRdrName unitTyCon = return (L l [])
634 = do p <- checkPred (L l t)
638 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
639 -- Watch out.. in ...deriving( Show )... we use checkPred on
640 -- the list of partially applied predicates in the deriving,
641 -- so there can be zero args.
642 checkPred (L spn (HsPredTy (HsIParam n ty)))
643 = return (L spn (HsIParam n ty))
647 checkl (L l ty) args = check l ty args
649 check _loc (HsPredTy pred@(HsEqualP _ _))
651 = return $ L spn pred
652 check _loc (HsTyVar t) args | not (isRdrTyVar t)
653 = return (L spn (HsClassP t args))
654 check _loc (HsAppTy l r) args = checkl l (r:args)
655 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
656 check _loc (HsParTy t) args = checkl t args
657 check loc _ _ = parseError loc
658 "malformed class assertion"
660 ---------------------------------------------------------------------------
661 -- Checking stand-alone deriving declarations
663 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
664 checkDerivDecl d@(L loc _) =
665 do stDerivOn <- extension standaloneDerivingEnabled
666 if stDerivOn then return d
667 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
669 ---------------------------------------------------------------------------
670 -- Checking statements in a do-expression
671 -- We parse do { e1 ; e2 ; }
672 -- as [ExprStmt e1, ExprStmt e2]
673 -- checkDo (a) checks that the last thing is an ExprStmt
674 -- (b) returns it separately
675 -- same comments apply for mdo as well
677 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
679 checkDo = checkDoMDo "a " "'do'"
680 checkMDo = checkDoMDo "an " "'mdo'"
682 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
683 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
684 checkDoMDo pre nm _ ss = do
687 check [] = panic "RdrHsSyn:checkDoMDo"
688 check [L _ (ExprStmt e _ _)] = return ([], e)
689 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
690 " construct must be an expression")
695 -- -------------------------------------------------------------------------
696 -- Checking Patterns.
698 -- We parse patterns as expressions and check for valid patterns below,
699 -- converting the expression into a pattern at the same time.
701 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
702 checkPattern e = checkLPat e
704 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
705 checkPatterns es = mapM checkPattern es
707 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
708 checkLPat e@(L l _) = checkPat l e []
710 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
711 checkPat loc (L l (HsVar c)) args
712 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
713 checkPat loc e args -- OK to let this happen even if bang-patterns
714 -- are not enabled, because there is no valid
715 -- non-bang-pattern parse of (C ! e)
716 | Just (e', args') <- splitBang e
717 = do { args'' <- checkPatterns args'
718 ; checkPat loc e' (args'' ++ args) }
719 checkPat loc (L _ (HsApp f x)) args
720 = do { x <- checkLPat x; checkPat loc f (x:args) }
721 checkPat loc (L _ e) []
722 = do { pState <- getPState
723 ; p <- checkAPat (dflags pState) loc e
728 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
729 checkAPat dynflags loc e = case e of
730 EWildPat -> return (WildPat placeHolderType)
731 HsVar x -> return (VarPat x)
732 HsLit l -> return (LitPat l)
734 -- Overloaded numeric patterns (e.g. f 0 x = x)
735 -- Negation is recorded separately, so that the literal is zero or +ve
736 -- NB. Negative *primitive* literals are already handled by the lexer
737 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
738 NegApp (L _ (HsOverLit pos_lit)) _
739 -> return (mkNPat pos_lit (Just noSyntaxExpr))
741 SectionR (L _ (HsVar bang)) e -- (! x)
743 -> do { bang_on <- extension bangPatEnabled
744 ; if bang_on then checkLPat e >>= (return . BangPat)
745 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
747 ELazyPat e -> checkLPat e >>= (return . LazyPat)
748 EAsPat n e -> checkLPat e >>= (return . AsPat n)
749 -- view pattern is well-formed if the pattern is
750 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
751 ExprWithTySig e t -> do e <- checkLPat e
752 -- Pattern signatures are parsed as sigtypes,
753 -- but they aren't explicit forall points. Hence
754 -- we have to remove the implicit forall here.
756 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
758 return (SigPatIn e t')
761 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
762 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
763 | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
764 -> return (mkNPlusKPat (L nloc n) lit)
766 OpApp l op _fix r -> do l <- checkLPat l
769 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
770 -> return (ConPatIn (L cl c) (InfixCon l r))
773 HsPar e -> checkLPat e >>= (return . ParPat)
774 ExplicitList _ es -> do ps <- mapM checkLPat es
775 return (ListPat ps placeHolderType)
776 ExplicitPArr _ es -> do ps <- mapM checkLPat es
777 return (PArrPat ps placeHolderType)
780 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
781 return (TuplePat ps b placeHolderType)
782 | otherwise -> parseError loc "Illegal tuple section in pattern"
784 RecordCon c _ (HsRecFields fs dd)
785 -> do fs <- mapM checkPatField fs
786 return (ConPatIn c (RecCon (HsRecFields fs dd)))
787 HsQuasiQuoteE q -> return (QuasiQuotePat q)
789 HsType ty -> return (TypePat ty)
792 plus_RDR, bang_RDR :: RdrName
793 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
794 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
796 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
797 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
798 ; return (fld { hsRecFieldArg = p }) }
800 patFail :: SrcSpan -> P a
801 patFail loc = parseError loc "Parse error in pattern"
804 ---------------------------------------------------------------------------
805 -- Check Equation Syntax
807 checkValDef :: LHsExpr RdrName
808 -> Maybe (LHsType RdrName)
809 -> Located (GRHSs RdrName)
810 -> P (HsBind RdrName)
812 checkValDef lhs (Just sig) grhss
813 -- x :: ty = rhs parses as a *pattern* binding
814 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
816 checkValDef lhs opt_sig grhss
817 = do { mb_fun <- isFunLhs lhs
819 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
820 fun is_infix pats opt_sig grhss
821 Nothing -> checkPatBind lhs grhss }
823 checkFunBind :: SrcSpan
827 -> Maybe (LHsType RdrName)
828 -> Located (GRHSs RdrName)
829 -> P (HsBind RdrName)
830 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
831 = do ps <- checkPatterns pats
832 let match_span = combineSrcSpans lhs_loc rhs_span
833 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
834 -- The span of the match covers the entire equation.
835 -- That isn't quite right, but it'll do for now.
837 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
838 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
839 makeFunBind fn is_infix ms
840 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
841 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
843 checkPatBind :: LHsExpr RdrName
844 -> Located (GRHSs RdrName)
845 -> P (HsBind RdrName)
846 checkPatBind lhs (L _ grhss)
847 = do { lhs <- checkPattern lhs
848 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
854 checkValSig (L l (HsVar v)) ty
855 | isUnqual v && not (isDataOcc (rdrNameOcc v))
856 = return (TypeSig (L l v) ty)
857 checkValSig (L l _) _
858 = parseError l "Invalid type signature"
863 -- The parser left-associates, so there should
864 -- not be any OpApps inside the e's
865 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
866 -- Splits (f ! g a b) into (f, [(! g), a, b])
867 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
868 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
870 (arg1,argns) = split_bang r_arg []
871 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
872 split_bang e es = (e,es)
873 splitBang _ = Nothing
875 isFunLhs :: LHsExpr RdrName
876 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
877 -- A variable binding is parsed as a FunBind.
878 -- Just (fun, is_infix, arg_pats) if e is a function LHS
880 -- The whole LHS is parsed as a single expression.
881 -- Any infix operators on the LHS will parse left-associatively
883 -- will parse (rather strangely) as
885 -- It's up to isFunLhs to sort out the mess
891 go (L loc (HsVar f)) es
892 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
893 go (L _ (HsApp f e)) es = go f (e:es)
894 go (L _ (HsPar e)) es@(_:_) = go e es
896 -- For infix function defns, there should be only one infix *function*
897 -- (though there may be infix *datacons* involved too). So we don't
898 -- need fixity info to figure out which function is being defined.
899 -- a `K1` b `op` c `K2` d
901 -- (a `K1` b) `op` (c `K2` d)
902 -- The renamer checks later that the precedences would yield such a parse.
904 -- There is a complication to deal with bang patterns.
906 -- ToDo: what about this?
907 -- x + 1 `op` y = ...
909 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
910 | Just (e',es') <- splitBang e
911 = do { bang_on <- extension bangPatEnabled
912 ; if bang_on then go e' (es' ++ es)
913 else return (Just (L loc' op, True, (l:r:es))) }
914 -- No bangs; behave just like the next case
915 | not (isRdrDataCon op) -- We have found the function!
916 = return (Just (L loc' op, True, (l:r:es)))
917 | otherwise -- Infix data con; keep going
918 = do { mb_l <- go l es
920 Just (op', True, j : k : es')
921 -> return (Just (op', True, j : op_app : es'))
923 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
924 _ -> return Nothing }
925 go _ _ = return Nothing
927 ---------------------------------------------------------------------------
928 -- Miscellaneous utilities
930 checkPrecP :: Located Int -> P Int
932 | 0 <= i && i <= maxPrecedence = return i
933 | otherwise = parseError l "Precedence out of range"
938 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
939 -> P (HsExpr RdrName)
941 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
942 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
943 mkRecConstrOrUpdate exp loc (fs,dd)
944 | null fs = parseError loc "Empty record update"
945 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
947 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
948 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
949 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
951 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
952 -- The Maybe is becuase the user can omit the activation spec (and usually does)
953 mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
955 mkInlineSpec Nothing match_info False = neverInlineSpec match_info
957 mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
959 -----------------------------------------------------------------------------
960 -- utilities for foreign declarations
962 -- construct a foreign import declaration
964 mkImport :: CCallConv
966 -> (Located FastString, Located RdrName, LHsType RdrName)
967 -> P (HsDecl RdrName)
968 mkImport cconv safety (L loc entity, v, ty)
969 | cconv == PrimCallConv = do
970 let funcTarget = CFunction (StaticTarget entity)
971 importSpec = CImport PrimCallConv safety nilFS funcTarget
972 return (ForD (ForeignImport v ty importSpec))
974 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
975 Nothing -> parseError loc "Malformed entity string"
976 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
978 -- the string "foo" is ambigous: either a header or a C identifier. The
979 -- C identifier case comes first in the alternatives below, so we pick
981 parseCImport :: CCallConv -> Safety -> FastString -> String
982 -> Maybe ForeignImport
983 parseCImport cconv safety nm str =
984 listToMaybe $ map fst $ filter (null.snd) $
988 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
989 string "wrapper" >> return (mk nilFS CWrapper),
990 optional (string "static" >> skipSpaces) >>
991 (mk nilFS <$> cimp nm) +++
992 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
995 mk = CImport cconv safety
997 hdr_char c = isAscii c && (isAlphaNum c || c `elem` "._")
998 id_char c = isAlphaNum c || c == '_'
1000 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1001 +++ ((CFunction . StaticTarget) <$> cid)
1004 (do c <- satisfy (\c -> isAlpha c || c == '_')
1005 cs <- many (satisfy id_char)
1006 return (mkFastString (c:cs)))
1009 -- construct a foreign export declaration
1011 mkExport :: CCallConv
1012 -> (Located FastString, Located RdrName, LHsType RdrName)
1013 -> P (HsDecl RdrName)
1014 mkExport cconv (L _ entity, v, ty) = return $
1015 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1017 entity' | nullFS entity = mkExtName (unLoc v)
1018 | otherwise = entity
1020 -- Supplying the ext_name in a foreign decl is optional; if it
1021 -- isn't there, the Haskell name is assumed. Note that no transformation
1022 -- of the Haskell name is then performed, so if you foreign export (++),
1023 -- it's external name will be "++". Too bad; it's important because we don't
1024 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1026 mkExtName :: RdrName -> CLabelString
1027 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1031 -----------------------------------------------------------------------------
1035 parseError :: SrcSpan -> String -> P a
1036 parseError span s = parseErrorSDoc span (text s)
1038 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1039 parseErrorSDoc span s = failSpanMsgP span s