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, mkInlineSpec,
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,
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 HsSpliceTyOut {} -> 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)) }
228 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
231 -- then that's the splice, but if she wrote, say,
233 -- then behave as if she'd written
236 = SpliceD (SpliceDecl expr')
239 (L _ (HsSpliceE (HsSplice _ expr))) -> expr
243 %************************************************************************
245 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
247 %************************************************************************
249 Function definitions are restructured here. Each is assumed to be recursive
250 initially, and non recursive definitions are discovered by the dependency
255 -- | Groups together bindings for a single function
256 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
257 cvTopDecls decls = go (fromOL decls)
259 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
261 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
262 where (L l' b', ds') = getMonoBind (L l b) ds
263 go (d : ds) = d : go ds
265 -- Declaration list may only contain value bindings and signatures.
266 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
268 = case cvBindsAndSigs binding of
269 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
272 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
273 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
274 -- Input decls contain just value bindings and signatures
275 -- and in case of class or instance declarations also
276 -- associated type declarations. They might also contain Haddock comments.
277 cvBindsAndSigs fb = go (fromOL fb)
279 go [] = (emptyBag, [], [], [])
280 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
281 where (bs, ss, ts, docs) = go ds
282 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
283 where (b', ds') = getMonoBind (L l b) ds
284 (bs, ss, ts, docs) = go ds'
285 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
286 where (bs, ss, ts, docs) = go ds
287 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
288 where (bs, ss, ts, docs) = go ds
289 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
291 -----------------------------------------------------------------------------
292 -- Group function bindings into equation groups
294 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
295 -> (LHsBind RdrName, [LHsDecl RdrName])
296 -- Suppose (b',ds') = getMonoBind b ds
297 -- ds is a list of parsed bindings
298 -- b is a MonoBinds that has just been read off the front
300 -- Then b' is the result of grouping more equations from ds that
301 -- belong with b into a single MonoBinds, and ds' is the depleted
302 -- list of parsed bindings.
304 -- All Haddock comments between equations inside the group are
307 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
309 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
310 fun_matches = MatchGroup mtchs1 _ })) binds
312 = go is_infix1 mtchs1 loc1 binds []
314 go is_infix mtchs loc
315 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
316 fun_matches = MatchGroup mtchs2 _ })) : binds) _
317 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
318 (combineSrcSpans loc loc2) binds []
319 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
320 = let doc_decls' = doc_decl : doc_decls
321 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
322 go is_infix mtchs loc binds doc_decls
323 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
324 -- Reverse the final matches, to get it back in the right order
325 -- Do the same thing with the trailing doc comments
327 getMonoBind bind binds = (bind, binds)
329 has_args :: [LMatch RdrName] -> Bool
330 has_args [] = panic "RdrHsSyn:has_args"
331 has_args ((L _ (Match args _ _)) : _) = not (null args)
332 -- Don't group together FunBinds if they have
333 -- no arguments. This is necessary now that variable bindings
334 -- with no arguments are now treated as FunBinds rather
335 -- than pattern bindings (tests/rename/should_fail/rnfail002).
339 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
340 findSplice ds = addl emptyRdrGroup ds
342 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
343 -- Turn the body of a [d| ... |] into a HsGroup
344 -- There should be no splices in the "..."
345 checkDecBrGroup decls
346 = case addl emptyRdrGroup decls of
347 (group, Nothing) -> return group
348 (_, Just (SpliceDecl (L loc _), _)) ->
349 parseError loc "Declaration splices are not permitted inside declaration brackets"
350 -- Why not? See Section 7.3 of the TH paper.
352 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
353 -- This stuff reverses the declarations (again) but it doesn't matter
356 addl gp [] = (gp, Nothing)
357 addl gp (L l d : ds) = add gp l d ds
360 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
361 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
363 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
365 -- Class declarations: pull out the fixity signatures to the top
366 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
369 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
370 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
372 addl (gp { hs_tyclds = L l d : ts }) ds
374 -- Signatures: fixity sigs go a different place than all others
375 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
376 = addl (gp {hs_fixds = L l f : ts}) ds
377 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
378 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
380 -- Value declarations: use add_bind
381 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
382 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
384 -- The rest are routine
385 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
386 = addl (gp { hs_instds = L l d : ts }) ds
387 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
388 = addl (gp { hs_derivds = L l d : ts }) ds
389 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
390 = addl (gp { hs_defds = L l d : ts }) ds
391 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
392 = addl (gp { hs_fords = L l d : ts }) ds
393 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
394 = addl (gp { hs_warnds = L l d : ts }) ds
395 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
396 = addl (gp { hs_annds = L l d : ts }) ds
397 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
398 = addl (gp { hs_ruleds = L l d : ts }) ds
401 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
403 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
404 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
405 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
407 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
408 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
409 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
412 %************************************************************************
414 \subsection[PrefixToHS-utils]{Utilities for conversion}
416 %************************************************************************
420 -----------------------------------------------------------------------------
423 -- When parsing data declarations, we sometimes inadvertently parse
424 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
425 -- This function splits up the type application, adds any pending
426 -- arguments, and converts the type constructor back into a data constructor.
428 splitCon :: LHsType RdrName
429 -> P (Located RdrName, HsConDeclDetails RdrName)
430 -- This gets given a "type" that should look like
432 -- or C { x::Int, y::Bool }
433 -- and returns the pieces
437 split (L _ (HsAppTy t u)) ts = split t (u : ts)
438 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
439 return (data_con, mk_rest ts)
440 split (L l _) _ = parseError l "parse error in data/newtype declaration"
442 mk_rest [L _ (HsRecTy flds)] = RecCon flds
443 mk_rest ts = PrefixCon ts
445 mkDeprecatedGadtRecordDecl :: SrcSpan
447 -> [ConDeclField RdrName]
449 -> P (LConDecl RdrName)
450 -- This one uses the deprecated syntax
451 -- C { x,y ::Int } :: T a b
452 -- We give it a RecCon details right away
453 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
454 = do { data_con <- tyConToDataCon con_loc con
455 ; return (L loc (ConDecl { con_old_rec = True
456 , con_name = data_con
457 , con_explicit = Implicit
460 , con_details = RecCon flds
461 , con_res = ResTyGADT res_ty
462 , con_doc = Nothing })) }
464 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
465 -> LHsContext RdrName -> HsConDeclDetails RdrName
468 mkSimpleConDecl name qvars cxt details
469 = ConDecl { con_old_rec = False
471 , con_explicit = Explicit
474 , con_details = details
476 , con_doc = Nothing }
478 mkGadtDecl :: [Located RdrName]
479 -> LHsType RdrName -- Always a HsForAllTy
481 -- We allow C,D :: ty
482 -- and expand it as if it had been
484 -- (Just like type signatures in general.)
485 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
486 = [mk_gadt_con name | name <- names]
488 (details, res_ty) -- See Note [Sorting out the result type]
490 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
491 _other -> (PrefixCon [], tau)
494 = ConDecl { con_old_rec = False
499 , con_details = details
500 , con_res = ResTyGADT res_ty
501 , con_doc = Nothing }
502 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
504 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
505 tyConToDataCon loc tc
506 | isTcOcc (rdrNameOcc tc)
507 = return (L loc (setRdrNameSpace tc srcDataName))
509 = parseErrorSDoc loc (msg $$ extra)
511 msg = text "Not a data constructor:" <+> quotes (ppr tc)
512 extra | tc == forall_tv_RDR
513 = text "Perhaps you intended to use -XExistentialQuantification"
517 Note [Sorting out the result type]
518 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
519 In a GADT declaration which is not a record, we put the whole constr
520 type into the ResTyGADT for now; the renamer will unravel it once it
521 has sorted out operator fixities. Consider for example
522 C :: a :*: b -> a :*: b -> a :+: b
523 Initially this type will parse as
524 a :*: (b -> (a :*: (b -> (a :+: b))))
526 so it's hard to split up the arguments until we've done the precedence
527 resolution (in the renamer) On the other hand, for a record
528 { x,y :: Int } -> a :*: b
529 there is no doubt. AND we need to sort records out so that
530 we can bring x,y into scope. So:
531 * For PrefixCon we keep all the args in the ResTyGADT
532 * For RecCon we do not
535 ----------------------------------------------------------------------------
536 -- Various Syntactic Checks
538 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
539 checkInstType (L l t)
541 HsForAllTy exp tvs ctxt ty -> do
542 dict_ty <- checkDictTy ty
543 return (L l (HsForAllTy exp tvs ctxt dict_ty))
545 HsParTy ty -> checkInstType ty
547 ty -> do dict_ty <- checkDictTy (L l ty)
548 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
550 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
551 checkDictTy (L spn ty) = check ty []
553 check (HsTyVar t) args | not (isRdrTyVar t)
554 = return (L spn (HsPredTy (HsClassP t args)))
555 check (HsAppTy l r) args = check (unLoc l) (r:args)
556 check (HsParTy t) args = check (unLoc t) args
557 check _ _ = parseError spn "Malformed instance header"
559 checkTParams :: Bool -- Type/data family
561 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
562 -- checkTParams checks the type parameters of a data/newtype declaration
563 -- There are two cases:
565 -- a) Vanilla data/newtype decl. In that case
566 -- - the type parameters should all be type variables
567 -- - they may have a kind annotation
569 -- b) Family data/newtype decl. In that case
570 -- - The type parameters may be arbitrary types
571 -- - We find the type-varaible binders by find the
572 -- free type vars of those types
573 -- - We make them all kind-sig-free binders (UserTyVar)
574 -- If there are kind sigs in the type parameters, they
575 -- will fix the binder's kind when we kind-check the
577 checkTParams is_family tparams
578 | not is_family -- Vanilla case (a)
579 = do { tyvars <- checkTyVars tparams
580 ; return (tyvars, Nothing) }
581 | otherwise -- Family case (b)
582 = do { let tyvars = [L l (UserTyVar tv)
583 | L l tv <- extractHsTysRdrTyVars tparams]
584 ; return (tyvars, Just tparams) }
586 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
587 -- Check whether the given list of type parameters are all type variables
588 -- (possibly with a kind signature). If the second argument is `False',
589 -- only type variables are allowed and we raise an error on encountering a
590 -- non-variable; otherwise, we allow non-variable arguments and return the
591 -- entire list of parameters.
592 checkTyVars tparms = mapM chk tparms
594 -- Check that the name space is correct!
595 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
596 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
597 chk (L l (HsTyVar tv))
598 | isRdrTyVar tv = return (L l (UserTyVar tv))
600 parseError l "Type found where type variable expected"
602 checkTyClHdr :: LHsType RdrName
603 -> P (Located RdrName, -- the head symbol (type or class name)
604 [LHsType RdrName]) -- parameters of head symbol
605 -- Well-formedness check and decomposition of type and class heads.
606 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
607 -- Int :*: Bool into (:*:, [Int, Bool])
608 -- returning the pieces
612 goL (L l ty) acc = go l ty acc
614 go l (HsTyVar tc) acc
615 | isRdrTc tc = return (L l tc, acc)
617 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
618 | isRdrTc tc = return (ltc, t1:t2:acc)
619 go _ (HsParTy ty) acc = goL ty acc
620 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
621 go l _ _ = parseError l "Malformed head of type or class declaration"
623 -- Check that associated type declarations of a class are all kind signatures.
625 checkKindSigs :: [LTyClDecl RdrName] -> P ()
626 checkKindSigs = mapM_ check
629 | isFamilyDecl tydecl
630 || isSynDecl tydecl = return ()
632 parseError l "Type declaration in a class must be a kind signature or synonym default"
634 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
638 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
639 = do ctx <- mapM checkPred ts
642 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
645 check (HsTyVar t) -- Empty context shows up as a unit type ()
646 | t == getRdrName unitTyCon = return (L l [])
649 = do p <- checkPred (L l t)
653 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
654 -- Watch out.. in ...deriving( Show )... we use checkPred on
655 -- the list of partially applied predicates in the deriving,
656 -- so there can be zero args.
657 checkPred (L spn (HsPredTy (HsIParam n ty)))
658 = return (L spn (HsIParam n ty))
662 checkl (L l ty) args = check l ty args
664 check _loc (HsPredTy pred@(HsEqualP _ _))
666 = return $ L spn pred
667 check _loc (HsTyVar t) args | not (isRdrTyVar t)
668 = return (L spn (HsClassP t args))
669 check _loc (HsAppTy l r) args = checkl l (r:args)
670 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
671 check _loc (HsParTy t) args = checkl t args
672 check loc _ _ = parseError loc
673 "malformed class assertion"
675 ---------------------------------------------------------------------------
676 -- Checking statements in a do-expression
677 -- We parse do { e1 ; e2 ; }
678 -- as [ExprStmt e1, ExprStmt e2]
679 -- checkDo (a) checks that the last thing is an ExprStmt
680 -- (b) returns it separately
681 -- same comments apply for mdo as well
683 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
685 checkDo = checkDoMDo "a " "'do'"
686 checkMDo = checkDoMDo "an " "'mdo'"
688 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
689 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
690 checkDoMDo pre nm _ ss = do
693 check [] = panic "RdrHsSyn:checkDoMDo"
694 check [L _ (ExprStmt e _ _)] = return ([], e)
695 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
696 " construct must be an expression")
701 -- -------------------------------------------------------------------------
702 -- Checking Patterns.
704 -- We parse patterns as expressions and check for valid patterns below,
705 -- converting the expression into a pattern at the same time.
707 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
708 checkPattern e = checkLPat e
710 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
711 checkPatterns es = mapM checkPattern es
713 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
714 checkLPat e@(L l _) = checkPat l e []
716 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
717 checkPat loc (L l (HsVar c)) args
718 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
719 checkPat loc e args -- OK to let this happen even if bang-patterns
720 -- are not enabled, because there is no valid
721 -- non-bang-pattern parse of (C ! e)
722 | Just (e', args') <- splitBang e
723 = do { args'' <- checkPatterns args'
724 ; checkPat loc e' (args'' ++ args) }
725 checkPat loc (L _ (HsApp f x)) args
726 = do { x <- checkLPat x; checkPat loc f (x:args) }
727 checkPat loc (L _ e) []
728 = do { pState <- getPState
729 ; p <- checkAPat (dflags pState) loc e
734 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
735 checkAPat dynflags loc e = case e of
736 EWildPat -> return (WildPat placeHolderType)
737 HsVar x -> return (VarPat x)
738 HsLit l -> return (LitPat l)
740 -- Overloaded numeric patterns (e.g. f 0 x = x)
741 -- Negation is recorded separately, so that the literal is zero or +ve
742 -- NB. Negative *primitive* literals are already handled by the lexer
743 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
744 NegApp (L _ (HsOverLit pos_lit)) _
745 -> return (mkNPat pos_lit (Just noSyntaxExpr))
747 SectionR (L _ (HsVar bang)) e -- (! x)
749 -> do { bang_on <- extension bangPatEnabled
750 ; if bang_on then checkLPat e >>= (return . BangPat)
751 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
753 ELazyPat e -> checkLPat e >>= (return . LazyPat)
754 EAsPat n e -> checkLPat e >>= (return . AsPat n)
755 -- view pattern is well-formed if the pattern is
756 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
757 ExprWithTySig e t -> do e <- checkLPat e
758 -- Pattern signatures are parsed as sigtypes,
759 -- but they aren't explicit forall points. Hence
760 -- we have to remove the implicit forall here.
762 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
764 return (SigPatIn e t')
767 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
768 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
769 | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
770 -> return (mkNPlusKPat (L nloc n) lit)
772 OpApp l op _fix r -> do l <- checkLPat l
775 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
776 -> return (ConPatIn (L cl c) (InfixCon l r))
779 HsPar e -> checkLPat e >>= (return . ParPat)
780 ExplicitList _ es -> do ps <- mapM checkLPat es
781 return (ListPat ps placeHolderType)
782 ExplicitPArr _ es -> do ps <- mapM checkLPat es
783 return (PArrPat ps placeHolderType)
786 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
787 return (TuplePat ps b placeHolderType)
788 | otherwise -> parseError loc "Illegal tuple section in pattern"
790 RecordCon c _ (HsRecFields fs dd)
791 -> do fs <- mapM checkPatField fs
792 return (ConPatIn c (RecCon (HsRecFields fs dd)))
793 HsQuasiQuoteE q -> return (QuasiQuotePat q)
795 HsType ty -> return (TypePat ty)
798 placeHolderPunRhs :: HsExpr RdrName
799 -- The RHS of a punned record field will be filled in by the renamer
800 -- It's better not to make it an error, in case we want to print it when debugging
801 placeHolderPunRhs = HsVar pun_RDR
803 plus_RDR, bang_RDR, pun_RDR :: RdrName
804 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
805 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
806 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
808 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
809 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
810 ; return (fld { hsRecFieldArg = p }) }
812 patFail :: SrcSpan -> P a
813 patFail loc = parseError loc "Parse error in pattern"
816 ---------------------------------------------------------------------------
817 -- Check Equation Syntax
819 checkValDef :: LHsExpr RdrName
820 -> Maybe (LHsType RdrName)
821 -> Located (GRHSs RdrName)
822 -> P (HsBind RdrName)
824 checkValDef lhs (Just sig) grhss
825 -- x :: ty = rhs parses as a *pattern* binding
826 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
828 checkValDef lhs opt_sig grhss
829 = do { mb_fun <- isFunLhs lhs
831 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
832 fun is_infix pats opt_sig grhss
833 Nothing -> checkPatBind lhs grhss }
835 checkFunBind :: SrcSpan
839 -> Maybe (LHsType RdrName)
840 -> Located (GRHSs RdrName)
841 -> P (HsBind RdrName)
842 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
843 = do ps <- checkPatterns pats
844 let match_span = combineSrcSpans lhs_loc rhs_span
845 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
846 -- The span of the match covers the entire equation.
847 -- That isn't quite right, but it'll do for now.
849 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
850 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
851 makeFunBind fn is_infix ms
852 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
853 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
855 checkPatBind :: LHsExpr RdrName
856 -> Located (GRHSs RdrName)
857 -> P (HsBind RdrName)
858 checkPatBind lhs (L _ grhss)
859 = do { lhs <- checkPattern lhs
860 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
866 checkValSig (L l (HsVar v)) ty
867 | isUnqual v && not (isDataOcc (rdrNameOcc v))
868 = return (TypeSig (L l v) ty)
869 checkValSig (L l _) _
870 = parseError l "Invalid type signature"
875 -- The parser left-associates, so there should
876 -- not be any OpApps inside the e's
877 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
878 -- Splits (f ! g a b) into (f, [(! g), a, b])
879 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
880 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
882 (arg1,argns) = split_bang r_arg []
883 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
884 split_bang e es = (e,es)
885 splitBang _ = Nothing
887 isFunLhs :: LHsExpr RdrName
888 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
889 -- A variable binding is parsed as a FunBind.
890 -- Just (fun, is_infix, arg_pats) if e is a function LHS
892 -- The whole LHS is parsed as a single expression.
893 -- Any infix operators on the LHS will parse left-associatively
895 -- will parse (rather strangely) as
897 -- It's up to isFunLhs to sort out the mess
903 go (L loc (HsVar f)) es
904 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
905 go (L _ (HsApp f e)) es = go f (e:es)
906 go (L _ (HsPar e)) es@(_:_) = go e es
908 -- For infix function defns, there should be only one infix *function*
909 -- (though there may be infix *datacons* involved too). So we don't
910 -- need fixity info to figure out which function is being defined.
911 -- a `K1` b `op` c `K2` d
913 -- (a `K1` b) `op` (c `K2` d)
914 -- The renamer checks later that the precedences would yield such a parse.
916 -- There is a complication to deal with bang patterns.
918 -- ToDo: what about this?
919 -- x + 1 `op` y = ...
921 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
922 | Just (e',es') <- splitBang e
923 = do { bang_on <- extension bangPatEnabled
924 ; if bang_on then go e' (es' ++ es)
925 else return (Just (L loc' op, True, (l:r:es))) }
926 -- No bangs; behave just like the next case
927 | not (isRdrDataCon op) -- We have found the function!
928 = return (Just (L loc' op, True, (l:r:es)))
929 | otherwise -- Infix data con; keep going
930 = do { mb_l <- go l es
932 Just (op', True, j : k : es')
933 -> return (Just (op', True, j : op_app : es'))
935 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
936 _ -> return Nothing }
937 go _ _ = return Nothing
939 ---------------------------------------------------------------------------
940 -- Miscellaneous utilities
942 checkPrecP :: Located Int -> P Int
944 | 0 <= i && i <= maxPrecedence = return i
945 | otherwise = parseError l "Precedence out of range"
950 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
951 -> P (HsExpr RdrName)
953 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
954 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
955 mkRecConstrOrUpdate exp loc (fs,dd)
956 | null fs = parseError loc "Empty record update"
957 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
959 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
960 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
961 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
963 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
964 -- The Maybe is becuase the user can omit the activation spec (and usually does)
965 mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
967 mkInlineSpec Nothing match_info False = neverInlineSpec match_info
969 mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
971 -----------------------------------------------------------------------------
972 -- utilities for foreign declarations
974 -- construct a foreign import declaration
976 mkImport :: CCallConv
978 -> (Located FastString, Located RdrName, LHsType RdrName)
979 -> P (HsDecl RdrName)
980 mkImport cconv safety (L loc entity, v, ty)
981 | cconv == PrimCallConv = do
982 let funcTarget = CFunction (StaticTarget entity)
983 importSpec = CImport PrimCallConv safety nilFS funcTarget
984 return (ForD (ForeignImport v ty importSpec))
986 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
987 Nothing -> parseError loc "Malformed entity string"
988 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
990 -- the string "foo" is ambigous: either a header or a C identifier. The
991 -- C identifier case comes first in the alternatives below, so we pick
993 parseCImport :: CCallConv -> Safety -> FastString -> String
994 -> Maybe ForeignImport
995 parseCImport cconv safety nm str =
996 listToMaybe $ map fst $ filter (null.snd) $
1000 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
1001 string "wrapper" >> return (mk nilFS CWrapper),
1002 optional (string "static" >> skipSpaces) >>
1003 (mk nilFS <$> cimp nm) +++
1004 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
1007 mk = CImport cconv safety
1009 hdr_char c = isAscii c && (isAlphaNum c || c `elem` "._")
1010 id_char c = isAlphaNum c || c == '_'
1012 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1013 +++ ((CFunction . StaticTarget) <$> cid)
1016 (do c <- satisfy (\c -> isAlpha c || c == '_')
1017 cs <- many (satisfy id_char)
1018 return (mkFastString (c:cs)))
1021 -- construct a foreign export declaration
1023 mkExport :: CCallConv
1024 -> (Located FastString, Located RdrName, LHsType RdrName)
1025 -> P (HsDecl RdrName)
1026 mkExport cconv (L _ entity, v, ty) = return $
1027 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1029 entity' | nullFS entity = mkExtName (unLoc v)
1030 | otherwise = entity
1032 -- Supplying the ext_name in a foreign decl is optional; if it
1033 -- isn't there, the Haskell name is assumed. Note that no transformation
1034 -- of the Haskell name is then performed, so if you foreign export (++),
1035 -- it's external name will be "++". Too bad; it's important because we don't
1036 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1038 mkExtName :: RdrName -> CLabelString
1039 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1043 -----------------------------------------------------------------------------
1047 parseError :: SrcSpan -> String -> P a
1048 parseError span s = parseErrorSDoc span (text s)
1050 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1051 parseErrorSDoc span s = failSpanMsgP span s