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
25 mkImport, -- CallConv -> Safety
26 -- -> (FastString, RdrName, RdrNameHsType)
29 -- -> (FastString, RdrName, RdrNameHsType)
31 mkExtName, -- RdrName -> CLabelString
32 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
34 mkDeprecatedGadtRecordDecl,
36 -- Bunch of functions in the parser monad for
37 -- checking and constructing values
38 checkPrecP, -- Int -> P Int
39 checkContext, -- HsType -> P HsContext
40 checkPred, -- HsType -> P HsPred
41 checkTyVars, -- [LHsType RdrName] -> P ()
42 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
43 checkInstType, -- HsType -> P HsType
44 checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
45 checkPattern, -- HsExp -> P HsPat
47 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
48 checkDo, -- [Stmt] -> P [Stmt]
49 checkMDo, -- [Stmt] -> P [Stmt]
50 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
51 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
56 import HsSyn -- Lots of it
57 import Class ( FunDep )
58 import TypeRep ( Kind )
59 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
60 isRdrDataCon, isUnqual, getRdrName, isQual,
61 setRdrNameSpace, showRdrName )
62 import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
63 InlinePragma(..), InlineSpec(..),
64 alwaysInlineSpec, neverInlineSpec )
65 import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
66 import TysWiredIn ( unitTyCon )
67 import ForeignCall ( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..),
68 DNCallSpec(..), DNKind(..), CLabelString )
69 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
71 import PrelNames ( forall_tv_RDR )
73 import OrdList ( OrdList, fromOL )
74 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
78 import List ( isSuffixOf, nubBy )
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 { p <- checkAPat loc e; return (L loc p) }
727 checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
728 checkAPat loc e = case e of
729 EWildPat -> return (WildPat placeHolderType)
730 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
732 | otherwise -> return (VarPat x)
733 HsLit l -> return (LitPat l)
735 -- Overloaded numeric patterns (e.g. f 0 x = x)
736 -- Negation is recorded separately, so that the literal is zero or +ve
737 -- NB. Negative *primitive* literals are already handled by the lexer
738 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
739 NegApp (L _ (HsOverLit pos_lit)) _
740 -> return (mkNPat pos_lit (Just noSyntaxExpr))
742 SectionR (L _ (HsVar bang)) e -- (! x)
744 -> do { bang_on <- extension bangPatEnabled
745 ; if bang_on then checkLPat e >>= (return . BangPat)
746 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
748 ELazyPat e -> checkLPat e >>= (return . LazyPat)
749 EAsPat n e -> checkLPat e >>= (return . AsPat n)
750 -- view pattern is well-formed if the pattern is
751 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
752 ExprWithTySig e t -> do e <- checkLPat e
753 -- Pattern signatures are parsed as sigtypes,
754 -- but they aren't explicit forall points. Hence
755 -- we have to remove the implicit forall here.
757 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
759 return (SigPatIn e t')
762 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
763 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
765 -> return (mkNPlusKPat (L nloc n) lit)
767 OpApp l op _fix r -> do l <- checkLPat l
770 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
771 -> return (ConPatIn (L cl c) (InfixCon l r))
774 HsPar e -> checkLPat e >>= (return . ParPat)
775 ExplicitList _ es -> do ps <- mapM checkLPat es
776 return (ListPat ps placeHolderType)
777 ExplicitPArr _ es -> do ps <- mapM checkLPat es
778 return (PArrPat ps placeHolderType)
780 ExplicitTuple es b -> do ps <- mapM checkLPat es
781 return (TuplePat ps b placeHolderType)
783 RecordCon c _ (HsRecFields fs dd)
784 -> do fs <- mapM checkPatField fs
785 return (ConPatIn c (RecCon (HsRecFields fs dd)))
786 HsQuasiQuoteE q -> return (QuasiQuotePat q)
788 HsType ty -> return (TypePat ty)
791 plus_RDR, bang_RDR :: RdrName
792 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
793 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
795 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
796 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
797 ; return (fld { hsRecFieldArg = p }) }
799 patFail :: SrcSpan -> P a
800 patFail loc = parseError loc "Parse error in pattern"
803 ---------------------------------------------------------------------------
804 -- Check Equation Syntax
806 checkValDef :: LHsExpr RdrName
807 -> Maybe (LHsType RdrName)
808 -> Located (GRHSs RdrName)
809 -> P (HsBind RdrName)
811 checkValDef lhs (Just sig) grhss
812 -- x :: ty = rhs parses as a *pattern* binding
813 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
815 checkValDef lhs opt_sig grhss
816 = do { mb_fun <- isFunLhs lhs
818 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
819 fun is_infix pats opt_sig grhss
820 Nothing -> checkPatBind lhs grhss }
822 checkFunBind :: SrcSpan
826 -> Maybe (LHsType RdrName)
827 -> Located (GRHSs RdrName)
828 -> P (HsBind RdrName)
829 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
831 = parseErrorSDoc (getLoc fun)
832 (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
834 = do ps <- checkPatterns pats
835 let match_span = combineSrcSpans lhs_loc rhs_span
836 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
837 -- The span of the match covers the entire equation.
838 -- That isn't quite right, but it'll do for now.
840 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
841 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
842 makeFunBind fn is_infix ms
843 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
844 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
846 checkPatBind :: LHsExpr RdrName
847 -> Located (GRHSs RdrName)
848 -> P (HsBind RdrName)
849 checkPatBind lhs (L _ grhss)
850 = do { lhs <- checkPattern lhs
851 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
857 checkValSig (L l (HsVar v)) ty
858 | isUnqual v && not (isDataOcc (rdrNameOcc v))
859 = return (TypeSig (L l v) ty)
860 checkValSig (L l _) _
861 = parseError l "Invalid type signature"
866 -- The parser left-associates, so there should
867 -- not be any OpApps inside the e's
868 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
869 -- Splits (f ! g a b) into (f, [(! g), a, b])
870 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
871 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
873 (arg1,argns) = split_bang r_arg []
874 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
875 split_bang e es = (e,es)
876 splitBang _ = Nothing
878 isFunLhs :: LHsExpr RdrName
879 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
880 -- A variable binding is parsed as a FunBind.
881 -- Just (fun, is_infix, arg_pats) if e is a function LHS
883 -- The whole LHS is parsed as a single expression.
884 -- Any infix operators on the LHS will parse left-associatively
886 -- will parse (rather strangely) as
888 -- It's up to isFunLhs to sort out the mess
894 go (L loc (HsVar f)) es
895 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
896 go (L _ (HsApp f e)) es = go f (e:es)
897 go (L _ (HsPar e)) es@(_:_) = go e es
899 -- For infix function defns, there should be only one infix *function*
900 -- (though there may be infix *datacons* involved too). So we don't
901 -- need fixity info to figure out which function is being defined.
902 -- a `K1` b `op` c `K2` d
904 -- (a `K1` b) `op` (c `K2` d)
905 -- The renamer checks later that the precedences would yield such a parse.
907 -- There is a complication to deal with bang patterns.
909 -- ToDo: what about this?
910 -- x + 1 `op` y = ...
912 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
913 | Just (e',es') <- splitBang e
914 = do { bang_on <- extension bangPatEnabled
915 ; if bang_on then go e' (es' ++ es)
916 else return (Just (L loc' op, True, (l:r:es))) }
917 -- No bangs; behave just like the next case
918 | not (isRdrDataCon op) -- We have found the function!
919 = return (Just (L loc' op, True, (l:r:es)))
920 | otherwise -- Infix data con; keep going
921 = do { mb_l <- go l es
923 Just (op', True, j : k : es')
924 -> return (Just (op', True, j : op_app : es'))
926 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
927 _ -> return Nothing }
928 go _ _ = return Nothing
930 ---------------------------------------------------------------------------
931 -- Miscellaneous utilities
933 checkPrecP :: Located Int -> P Int
935 | 0 <= i && i <= maxPrecedence = return i
936 | otherwise = parseError l "Precedence out of range"
941 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
942 -> P (HsExpr RdrName)
944 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
945 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
946 mkRecConstrOrUpdate exp loc (fs,dd)
947 | null fs = parseError loc "Empty record update"
948 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
950 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
951 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
952 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
954 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
955 -- The Maybe is becuase the user can omit the activation spec (and usually does)
956 mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
958 mkInlineSpec Nothing match_info False = neverInlineSpec match_info
960 mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
963 -----------------------------------------------------------------------------
964 -- utilities for foreign declarations
966 -- supported calling conventions
968 data CallConv = CCall CCallConv -- ccall or stdcall
971 -- construct a foreign import declaration
975 -> (Located FastString, Located RdrName, LHsType RdrName)
976 -> P (HsDecl RdrName)
977 mkImport (CCall cconv) safety (entity, v, ty)
978 | cconv == PrimCallConv = do
979 let funcTarget = CFunction (StaticTarget (unLoc entity))
980 importSpec = CImport PrimCallConv safety nilFS funcTarget
981 return (ForD (ForeignImport v ty importSpec))
983 importSpec <- parseCImport entity cconv safety v
984 return (ForD (ForeignImport v ty importSpec))
985 mkImport (DNCall ) _ (entity, v, ty) = do
986 spec <- parseDImport entity
987 return $ ForD (ForeignImport v ty (DNImport spec))
989 -- parse the entity string of a foreign import declaration for the `ccall' or
990 -- `stdcall' calling convention'
992 parseCImport :: Located FastString
997 parseCImport (L loc entity) cconv safety v
998 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
999 | entity == fsLit "dynamic" =
1000 return $ CImport cconv safety nilFS (CFunction DynamicTarget)
1001 | entity == fsLit "wrapper" =
1002 return $ CImport cconv safety nilFS CWrapper
1003 | otherwise = parse0 (unpackFS entity)
1005 -- using the static keyword?
1006 parse0 (' ': rest) = parse0 rest
1007 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
1008 parse0 rest = parse1 rest
1009 -- check for header file name
1010 parse1 "" = parse4 "" nilFS False
1011 parse1 (' ':rest) = parse1 rest
1012 parse1 str@('&':_ ) = parse2 str nilFS
1014 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
1015 | otherwise = parse4 str nilFS False
1017 (first, rest) = break (\c -> c == ' ' || c == '&') str
1018 -- check for address operator (indicating a label import)
1019 parse2 "" header = parse4 "" header False
1020 parse2 (' ':rest) header = parse2 rest header
1021 parse2 ('&':rest) header = parse3 rest header
1022 parse2 str header = parse4 str header False
1023 -- eat spaces after '&'
1024 parse3 (' ':rest) header = parse3 rest header
1025 parse3 str header = parse4 str header True
1026 -- check for name of C function
1027 parse4 "" header isLbl = build (mkExtName (unLoc v)) header isLbl
1028 parse4 (' ':rest) header isLbl = parse4 rest header isLbl
1029 parse4 str header isLbl
1030 | all (== ' ') rest = build (mkFastString first) header isLbl
1031 | otherwise = parseError loc "Malformed entity string"
1033 (first, rest) = break (== ' ') str
1035 build cid header False = return $
1036 CImport cconv safety header (CFunction (StaticTarget cid))
1037 build cid header True = return $
1038 CImport cconv safety header (CLabel cid )
1041 -- Unravel a dotnet spec string.
1043 parseDImport :: Located FastString -> P DNCallSpec
1044 parseDImport (L loc entity) = parse0 comps
1046 comps = words (unpackFS entity)
1050 | x == "static" = parse1 True xs
1051 | otherwise = parse1 False (x:xs)
1054 parse1 isStatic (x:xs)
1055 | x == "method" = parse2 isStatic DNMethod xs
1056 | x == "field" = parse2 isStatic DNField xs
1057 | x == "ctor" = parse2 isStatic DNConstructor xs
1058 parse1 isStatic xs = parse2 isStatic DNMethod xs
1060 parse2 _ _ [] = d'oh
1061 parse2 isStatic kind (('[':x):xs) =
1064 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1066 parse2 isStatic kind xs = parse3 isStatic kind "" xs
1068 parse3 isStatic kind assem [x] =
1069 return (DNCallSpec isStatic kind assem x
1070 -- these will be filled in once known.
1071 (error "FFI-dotnet-args")
1072 (error "FFI-dotnet-result"))
1073 parse3 _ _ _ _ = d'oh
1075 d'oh = parseError loc "Malformed entity string"
1077 -- construct a foreign export declaration
1079 mkExport :: CallConv
1080 -> (Located FastString, Located RdrName, LHsType RdrName)
1081 -> P (HsDecl RdrName)
1082 mkExport (CCall cconv) (L _ entity, v, ty) = return $
1083 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1085 entity' | nullFS entity = mkExtName (unLoc v)
1086 | otherwise = entity
1087 mkExport DNCall (L _ _, v, _) =
1088 parseError (getLoc v){-TODO: not quite right-}
1089 "Foreign export is not yet supported for .NET"
1091 -- Supplying the ext_name in a foreign decl is optional; if it
1092 -- isn't there, the Haskell name is assumed. Note that no transformation
1093 -- of the Haskell name is then performed, so if you foreign export (++),
1094 -- it's external name will be "++". Too bad; it's important because we don't
1095 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1097 mkExtName :: RdrName -> CLabelString
1098 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1102 -----------------------------------------------------------------------------
1106 parseError :: SrcSpan -> String -> P a
1107 parseError span s = parseErrorSDoc span (text s)
1109 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1110 parseErrorSDoc span s = failSpanMsgP span s