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)
781 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
782 return (TuplePat ps b placeHolderType)
783 | otherwise -> parseError loc "Illegal tuple section in pattern"
785 RecordCon c _ (HsRecFields fs dd)
786 -> do fs <- mapM checkPatField fs
787 return (ConPatIn c (RecCon (HsRecFields fs dd)))
788 HsQuasiQuoteE q -> return (QuasiQuotePat q)
790 HsType ty -> return (TypePat ty)
793 plus_RDR, bang_RDR :: RdrName
794 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
795 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
797 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
798 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
799 ; return (fld { hsRecFieldArg = p }) }
801 patFail :: SrcSpan -> P a
802 patFail loc = parseError loc "Parse error in pattern"
805 ---------------------------------------------------------------------------
806 -- Check Equation Syntax
808 checkValDef :: LHsExpr RdrName
809 -> Maybe (LHsType RdrName)
810 -> Located (GRHSs RdrName)
811 -> P (HsBind RdrName)
813 checkValDef lhs (Just sig) grhss
814 -- x :: ty = rhs parses as a *pattern* binding
815 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
817 checkValDef lhs opt_sig grhss
818 = do { mb_fun <- isFunLhs lhs
820 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
821 fun is_infix pats opt_sig grhss
822 Nothing -> checkPatBind lhs grhss }
824 checkFunBind :: SrcSpan
828 -> Maybe (LHsType RdrName)
829 -> Located (GRHSs RdrName)
830 -> P (HsBind RdrName)
831 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
833 = parseErrorSDoc (getLoc fun)
834 (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
836 = do ps <- checkPatterns pats
837 let match_span = combineSrcSpans lhs_loc rhs_span
838 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
839 -- The span of the match covers the entire equation.
840 -- That isn't quite right, but it'll do for now.
842 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
843 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
844 makeFunBind fn is_infix ms
845 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
846 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
848 checkPatBind :: LHsExpr RdrName
849 -> Located (GRHSs RdrName)
850 -> P (HsBind RdrName)
851 checkPatBind lhs (L _ grhss)
852 = do { lhs <- checkPattern lhs
853 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
859 checkValSig (L l (HsVar v)) ty
860 | isUnqual v && not (isDataOcc (rdrNameOcc v))
861 = return (TypeSig (L l v) ty)
862 checkValSig (L l _) _
863 = parseError l "Invalid type signature"
868 -- The parser left-associates, so there should
869 -- not be any OpApps inside the e's
870 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
871 -- Splits (f ! g a b) into (f, [(! g), a, b])
872 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
873 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
875 (arg1,argns) = split_bang r_arg []
876 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
877 split_bang e es = (e,es)
878 splitBang _ = Nothing
880 isFunLhs :: LHsExpr RdrName
881 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
882 -- A variable binding is parsed as a FunBind.
883 -- Just (fun, is_infix, arg_pats) if e is a function LHS
885 -- The whole LHS is parsed as a single expression.
886 -- Any infix operators on the LHS will parse left-associatively
888 -- will parse (rather strangely) as
890 -- It's up to isFunLhs to sort out the mess
896 go (L loc (HsVar f)) es
897 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
898 go (L _ (HsApp f e)) es = go f (e:es)
899 go (L _ (HsPar e)) es@(_:_) = go e es
901 -- For infix function defns, there should be only one infix *function*
902 -- (though there may be infix *datacons* involved too). So we don't
903 -- need fixity info to figure out which function is being defined.
904 -- a `K1` b `op` c `K2` d
906 -- (a `K1` b) `op` (c `K2` d)
907 -- The renamer checks later that the precedences would yield such a parse.
909 -- There is a complication to deal with bang patterns.
911 -- ToDo: what about this?
912 -- x + 1 `op` y = ...
914 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
915 | Just (e',es') <- splitBang e
916 = do { bang_on <- extension bangPatEnabled
917 ; if bang_on then go e' (es' ++ es)
918 else return (Just (L loc' op, True, (l:r:es))) }
919 -- No bangs; behave just like the next case
920 | not (isRdrDataCon op) -- We have found the function!
921 = return (Just (L loc' op, True, (l:r:es)))
922 | otherwise -- Infix data con; keep going
923 = do { mb_l <- go l es
925 Just (op', True, j : k : es')
926 -> return (Just (op', True, j : op_app : es'))
928 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
929 _ -> return Nothing }
930 go _ _ = return Nothing
932 ---------------------------------------------------------------------------
933 -- Miscellaneous utilities
935 checkPrecP :: Located Int -> P Int
937 | 0 <= i && i <= maxPrecedence = return i
938 | otherwise = parseError l "Precedence out of range"
943 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
944 -> P (HsExpr RdrName)
946 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
947 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
948 mkRecConstrOrUpdate exp loc (fs,dd)
949 | null fs = parseError loc "Empty record update"
950 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
952 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
953 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
954 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
956 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
957 -- The Maybe is becuase the user can omit the activation spec (and usually does)
958 mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
960 mkInlineSpec Nothing match_info False = neverInlineSpec match_info
962 mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
964 -----------------------------------------------------------------------------
965 -- utilities for foreign declarations
967 -- supported calling conventions
969 data CallConv = CCall CCallConv -- ccall or stdcall
972 -- construct a foreign import declaration
976 -> (Located FastString, Located RdrName, LHsType RdrName)
977 -> P (HsDecl RdrName)
978 mkImport (CCall cconv) safety (entity, v, ty)
979 | cconv == PrimCallConv = do
980 let funcTarget = CFunction (StaticTarget (unLoc entity))
981 importSpec = CImport PrimCallConv safety nilFS funcTarget
982 return (ForD (ForeignImport v ty importSpec))
984 importSpec <- parseCImport entity cconv safety v
985 return (ForD (ForeignImport v ty importSpec))
986 mkImport (DNCall ) _ (entity, v, ty) = do
987 spec <- parseDImport entity
988 return $ ForD (ForeignImport v ty (DNImport spec))
990 -- parse the entity string of a foreign import declaration for the `ccall' or
991 -- `stdcall' calling convention'
993 parseCImport :: Located FastString
998 parseCImport (L loc entity) cconv safety v
999 -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
1000 | entity == fsLit "dynamic" =
1001 return $ CImport cconv safety nilFS (CFunction DynamicTarget)
1002 | entity == fsLit "wrapper" =
1003 return $ CImport cconv safety nilFS CWrapper
1004 | otherwise = parse0 (unpackFS entity)
1006 -- using the static keyword?
1007 parse0 (' ': rest) = parse0 rest
1008 parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
1009 parse0 rest = parse1 rest
1010 -- check for header file name
1011 parse1 "" = parse4 "" nilFS False
1012 parse1 (' ':rest) = parse1 rest
1013 parse1 str@('&':_ ) = parse2 str nilFS
1015 | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
1016 | otherwise = parse4 str nilFS False
1018 (first, rest) = break (\c -> c == ' ' || c == '&') str
1019 -- check for address operator (indicating a label import)
1020 parse2 "" header = parse4 "" header False
1021 parse2 (' ':rest) header = parse2 rest header
1022 parse2 ('&':rest) header = parse3 rest header
1023 parse2 str header = parse4 str header False
1024 -- eat spaces after '&'
1025 parse3 (' ':rest) header = parse3 rest header
1026 parse3 str header = parse4 str header True
1027 -- check for name of C function
1028 parse4 "" header isLbl = build (mkExtName (unLoc v)) header isLbl
1029 parse4 (' ':rest) header isLbl = parse4 rest header isLbl
1030 parse4 str header isLbl
1031 | all (== ' ') rest = build (mkFastString first) header isLbl
1032 | otherwise = parseError loc "Malformed entity string"
1034 (first, rest) = break (== ' ') str
1036 build cid header False = return $
1037 CImport cconv safety header (CFunction (StaticTarget cid))
1038 build cid header True = return $
1039 CImport cconv safety header (CLabel cid )
1042 -- Unravel a dotnet spec string.
1044 parseDImport :: Located FastString -> P DNCallSpec
1045 parseDImport (L loc entity) = parse0 comps
1047 comps = words (unpackFS entity)
1051 | x == "static" = parse1 True xs
1052 | otherwise = parse1 False (x:xs)
1055 parse1 isStatic (x:xs)
1056 | x == "method" = parse2 isStatic DNMethod xs
1057 | x == "field" = parse2 isStatic DNField xs
1058 | x == "ctor" = parse2 isStatic DNConstructor xs
1059 parse1 isStatic xs = parse2 isStatic DNMethod xs
1061 parse2 _ _ [] = d'oh
1062 parse2 isStatic kind (('[':x):xs) =
1065 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1067 parse2 isStatic kind xs = parse3 isStatic kind "" xs
1069 parse3 isStatic kind assem [x] =
1070 return (DNCallSpec isStatic kind assem x
1071 -- these will be filled in once known.
1072 (error "FFI-dotnet-args")
1073 (error "FFI-dotnet-result"))
1074 parse3 _ _ _ _ = d'oh
1076 d'oh = parseError loc "Malformed entity string"
1078 -- construct a foreign export declaration
1080 mkExport :: CallConv
1081 -> (Located FastString, Located RdrName, LHsType RdrName)
1082 -> P (HsDecl RdrName)
1083 mkExport (CCall cconv) (L _ entity, v, ty) = return $
1084 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1086 entity' | nullFS entity = mkExtName (unLoc v)
1087 | otherwise = entity
1088 mkExport DNCall (L _ _, v, _) =
1089 parseError (getLoc v){-TODO: not quite right-}
1090 "Foreign export is not yet supported for .NET"
1092 -- Supplying the ext_name in a foreign decl is optional; if it
1093 -- isn't there, the Haskell name is assumed. Note that no transformation
1094 -- of the Haskell name is then performed, so if you foreign export (++),
1095 -- it's external name will be "++". Too bad; it's important because we don't
1096 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1098 mkExtName :: RdrName -> CLabelString
1099 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1103 -----------------------------------------------------------------------------
1107 parseError :: SrcSpan -> String -> P a
1108 parseError span s = parseErrorSDoc span (text s)
1110 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1111 parseErrorSDoc span s = failSpanMsgP span s