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)
30 -- -> (FastString, RdrName, RdrNameHsType)
32 mkExtName, -- RdrName -> CLabelString
33 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
35 mkDeprecatedGadtRecordDecl,
37 -- Bunch of functions in the parser monad for
38 -- checking and constructing values
39 checkPrecP, -- Int -> P Int
40 checkContext, -- HsType -> P HsContext
41 checkPred, -- HsType -> P HsPred
42 checkTyVars, -- [LHsType RdrName] -> P ()
43 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
44 checkInstType, -- HsType -> P HsType
45 checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
46 checkPattern, -- HsExp -> P HsPat
48 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
49 checkDo, -- [Stmt] -> P [Stmt]
50 checkMDo, -- [Stmt] -> P [Stmt]
51 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
52 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
57 import HsSyn -- Lots of it
58 import Class ( FunDep )
59 import TypeRep ( Kind )
60 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
61 isRdrDataCon, isUnqual, getRdrName, isQual,
62 setRdrNameSpace, showRdrName )
63 import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
64 InlinePragma(..), InlineSpec(..),
65 alwaysInlineSpec, neverInlineSpec )
66 import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
67 import TysWiredIn ( unitTyCon )
68 import ForeignCall ( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..),
69 DNCallSpec(..), DNKind(..), CLabelString )
70 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
72 import PrelNames ( forall_tv_RDR )
74 import OrdList ( OrdList, fromOL )
75 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
80 import Control.Applicative ((<$>))
81 import Text.ParserCombinators.ReadP as ReadP
82 import Data.List ( nubBy )
83 import Data.Char ( isAscii, isAlphaNum, isAlpha )
85 #include "HsVersions.h"
89 %************************************************************************
91 \subsection{A few functions over HsSyn at RdrName}
93 %************************************************************************
95 extractHsTyRdrNames finds the free variables of a HsType
96 It's used when making the for-alls explicit.
99 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
100 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
102 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
103 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
105 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
106 -- This one takes the context and tau-part of a
107 -- sigma type and returns their free type variables
108 extractHsRhoRdrTyVars ctxt ty
109 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
111 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
112 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
114 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
115 extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
116 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
117 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
119 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
120 extract_ltys tys acc = foldr extract_lty acc tys
122 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
123 extract_lty (L loc ty) acc
125 HsTyVar tv -> extract_tv loc tv acc
126 HsBangTy _ ty -> extract_lty ty acc
127 HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
128 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
129 HsListTy ty -> extract_lty ty acc
130 HsPArrTy ty -> extract_lty ty acc
131 HsTupleTy _ tys -> extract_ltys tys acc
132 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
133 HsPredTy p -> extract_pred p acc
134 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
135 HsParTy ty -> extract_lty ty acc
137 HsSpliceTy _ -> acc -- Type splices mention no type variables
138 HsKindSig ty _ -> extract_lty ty acc
139 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
140 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
141 extract_lctxt cx (extract_lty ty []))
143 locals = hsLTyVarNames tvs
144 HsDocTy ty _ -> extract_lty ty acc
146 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
147 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
150 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
151 -- Get the type variables out of the type patterns in a bunch of
152 -- possibly-generic bindings in a class declaration
153 extractGenericPatTyVars binds
154 = nubBy eqLocated (foldrBag get [] binds)
156 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
159 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
164 %************************************************************************
166 \subsection{Construction functions for Rdr stuff}
168 %************************************************************************
170 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
171 by deriving them from the name of the class. We fill in the names for the
172 tycon and datacon corresponding to the class, by deriving them from the
173 name of the class itself. This saves recording the names in the interface
174 file (which would be equally good).
176 Similarly for mkConDecl, mkClassOpSig and default-method names.
178 *** See "THE NAMING STORY" in HsDecls ****
181 mkClassDecl :: SrcSpan
182 -> Located (LHsContext RdrName, LHsType RdrName)
183 -> Located [Located (FunDep RdrName)]
184 -> Located (OrdList (LHsDecl RdrName))
185 -> P (LTyClDecl RdrName)
187 mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
188 = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
189 ; (cls, tparams) <- checkTyClHdr tycl_hdr
190 ; tyvars <- checkTyVars tparams -- Only type vars allowed
192 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
193 tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
194 tcdATs = ats, tcdDocs = docs })) }
198 -> Bool -- True <=> data family instance
199 -> Located (LHsContext RdrName, LHsType RdrName)
201 -> [LConDecl RdrName]
202 -> Maybe [LHsType RdrName]
203 -> P (LTyClDecl RdrName)
204 mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
205 = do { (tc, tparams) <- checkTyClHdr tycl_hdr
207 ; (tyvars, typats) <- checkTParams is_family tparams
208 ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
209 tcdTyVars = tyvars, tcdTyPats = typats,
211 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
213 mkTySynonym :: SrcSpan
214 -> Bool -- True <=> type family instances
215 -> LHsType RdrName -- LHS
216 -> LHsType RdrName -- RHS
217 -> P (LTyClDecl RdrName)
218 mkTySynonym loc is_family lhs rhs
219 = do { (tc, tparams) <- checkTyClHdr lhs
220 ; (tyvars, typats) <- checkTParams is_family tparams
221 ; return (L loc (TySynonym tc tyvars typats rhs)) }
223 mkTyFamily :: SrcSpan
225 -> LHsType RdrName -- LHS
226 -> Maybe Kind -- Optional kind signature
227 -> P (LTyClDecl RdrName)
228 mkTyFamily loc flavour lhs ksig
229 = do { (tc, tparams) <- checkTyClHdr lhs
230 ; tyvars <- checkTyVars tparams
231 ; return (L loc (TyFamily flavour tc tyvars ksig)) }
234 %************************************************************************
236 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
238 %************************************************************************
240 Function definitions are restructured here. Each is assumed to be recursive
241 initially, and non recursive definitions are discovered by the dependency
246 -- | Groups together bindings for a single function
247 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
248 cvTopDecls decls = go (fromOL decls)
250 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
252 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
253 where (L l' b', ds') = getMonoBind (L l b) ds
254 go (d : ds) = d : go ds
256 -- Declaration list may only contain value bindings and signatures.
257 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
259 = case cvBindsAndSigs binding of
260 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
263 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
264 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
265 -- Input decls contain just value bindings and signatures
266 -- and in case of class or instance declarations also
267 -- associated type declarations. They might also contain Haddock comments.
268 cvBindsAndSigs fb = go (fromOL fb)
270 go [] = (emptyBag, [], [], [])
271 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
272 where (bs, ss, ts, docs) = go ds
273 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
274 where (b', ds') = getMonoBind (L l b) ds
275 (bs, ss, ts, docs) = go ds'
276 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
277 where (bs, ss, ts, docs) = go ds
278 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
279 where (bs, ss, ts, docs) = go ds
280 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
282 -----------------------------------------------------------------------------
283 -- Group function bindings into equation groups
285 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
286 -> (LHsBind RdrName, [LHsDecl RdrName])
287 -- Suppose (b',ds') = getMonoBind b ds
288 -- ds is a list of parsed bindings
289 -- b is a MonoBinds that has just been read off the front
291 -- Then b' is the result of grouping more equations from ds that
292 -- belong with b into a single MonoBinds, and ds' is the depleted
293 -- list of parsed bindings.
295 -- All Haddock comments between equations inside the group are
298 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
300 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
301 fun_matches = MatchGroup mtchs1 _ })) binds
303 = go is_infix1 mtchs1 loc1 binds []
305 go is_infix mtchs loc
306 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
307 fun_matches = MatchGroup mtchs2 _ })) : binds) _
308 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
309 (combineSrcSpans loc loc2) binds []
310 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
311 = let doc_decls' = doc_decl : doc_decls
312 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
313 go is_infix mtchs loc binds doc_decls
314 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
315 -- Reverse the final matches, to get it back in the right order
316 -- Do the same thing with the trailing doc comments
318 getMonoBind bind binds = (bind, binds)
320 has_args :: [LMatch RdrName] -> Bool
321 has_args [] = panic "RdrHsSyn:has_args"
322 has_args ((L _ (Match args _ _)) : _) = not (null args)
323 -- Don't group together FunBinds if they have
324 -- no arguments. This is necessary now that variable bindings
325 -- with no arguments are now treated as FunBinds rather
326 -- than pattern bindings (tests/rename/should_fail/rnfail002).
330 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
331 findSplice ds = addl emptyRdrGroup ds
333 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
334 -- Turn the body of a [d| ... |] into a HsGroup
335 -- There should be no splices in the "..."
336 checkDecBrGroup decls
337 = case addl emptyRdrGroup decls of
338 (group, Nothing) -> return group
339 (_, Just (SpliceDecl (L loc _), _)) ->
340 parseError loc "Declaration splices are not permitted inside declaration brackets"
341 -- Why not? See Section 7.3 of the TH paper.
343 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
344 -- This stuff reverses the declarations (again) but it doesn't matter
347 addl gp [] = (gp, Nothing)
348 addl gp (L l d : ds) = add gp l d ds
351 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
352 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
354 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
356 -- Class declarations: pull out the fixity signatures to the top
357 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
360 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
361 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
363 addl (gp { hs_tyclds = L l d : ts }) ds
365 -- Signatures: fixity sigs go a different place than all others
366 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
367 = addl (gp {hs_fixds = L l f : ts}) ds
368 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
369 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
371 -- Value declarations: use add_bind
372 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
373 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
375 -- The rest are routine
376 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
377 = addl (gp { hs_instds = L l d : ts }) ds
378 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
379 = addl (gp { hs_derivds = L l d : ts }) ds
380 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
381 = addl (gp { hs_defds = L l d : ts }) ds
382 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
383 = addl (gp { hs_fords = L l d : ts }) ds
384 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
385 = addl (gp { hs_warnds = L l d : ts }) ds
386 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
387 = addl (gp { hs_annds = L l d : ts }) ds
388 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
389 = addl (gp { hs_ruleds = L l d : ts }) ds
392 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
394 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
395 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
396 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
398 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
399 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
400 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
403 %************************************************************************
405 \subsection[PrefixToHS-utils]{Utilities for conversion}
407 %************************************************************************
411 -----------------------------------------------------------------------------
414 -- When parsing data declarations, we sometimes inadvertently parse
415 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
416 -- This function splits up the type application, adds any pending
417 -- arguments, and converts the type constructor back into a data constructor.
419 splitCon :: LHsType RdrName
420 -> P (Located RdrName, HsConDeclDetails RdrName)
421 -- This gets given a "type" that should look like
423 -- or C { x::Int, y::Bool }
424 -- and returns the pieces
428 split (L _ (HsAppTy t u)) ts = split t (u : ts)
429 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
430 return (data_con, mk_rest ts)
431 split (L l _) _ = parseError l "parse error in data/newtype declaration"
433 mk_rest [L _ (HsRecTy flds)] = RecCon flds
434 mk_rest ts = PrefixCon ts
436 mkDeprecatedGadtRecordDecl :: SrcSpan
438 -> [ConDeclField RdrName]
440 -> P (LConDecl RdrName)
441 -- This one uses the deprecated syntax
442 -- C { x,y ::Int } :: T a b
443 -- We give it a RecCon details right away
444 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
445 = do { data_con <- tyConToDataCon con_loc con
446 ; return (L loc (ConDecl { con_old_rec = True
447 , con_name = data_con
448 , con_explicit = Implicit
451 , con_details = RecCon flds
452 , con_res = ResTyGADT res_ty
453 , con_doc = Nothing })) }
455 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
456 -> LHsContext RdrName -> HsConDeclDetails RdrName
459 mkSimpleConDecl name qvars cxt details
460 = ConDecl { con_old_rec = False
462 , con_explicit = Explicit
465 , con_details = details
467 , con_doc = Nothing }
469 mkGadtDecl :: [Located RdrName]
470 -> LHsType RdrName -- Always a HsForAllTy
472 -- We allow C,D :: ty
473 -- and expand it as if it had been
475 -- (Just like type signatures in general.)
476 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
477 = [mk_gadt_con name | name <- names]
479 (details, res_ty) -- See Note [Sorting out the result type]
481 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
482 _other -> (PrefixCon [], tau)
485 = ConDecl { con_old_rec = False
490 , con_details = details
491 , con_res = ResTyGADT res_ty
492 , con_doc = Nothing }
493 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
495 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
496 tyConToDataCon loc tc
497 | isTcOcc (rdrNameOcc tc)
498 = return (L loc (setRdrNameSpace tc srcDataName))
500 = parseErrorSDoc loc (msg $$ extra)
502 msg = text "Not a data constructor:" <+> quotes (ppr tc)
503 extra | tc == forall_tv_RDR
504 = text "Perhaps you intended to use -XExistentialQuantification"
508 Note [Sorting out the result type]
509 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
510 In a GADT declaration which is not a record, we put the whole constr
511 type into the ResTyGADT for now; the renamer will unravel it once it
512 has sorted out operator fixities. Consider for example
513 C :: a :*: b -> a :*: b -> a :+: b
514 Initially this type will parse as
515 a :*: (b -> (a :*: (b -> (a :+: b))))
517 so it's hard to split up the arguments until we've done the precedence
518 resolution (in the renamer) On the other hand, for a record
519 { x,y :: Int } -> a :*: b
520 there is no doubt. AND we need to sort records out so that
521 we can bring x,y into scope. So:
522 * For PrefixCon we keep all the args in the ResTyGADT
523 * For RecCon we do not
526 ----------------------------------------------------------------------------
527 -- Various Syntactic Checks
529 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
530 checkInstType (L l t)
532 HsForAllTy exp tvs ctxt ty -> do
533 dict_ty <- checkDictTy ty
534 return (L l (HsForAllTy exp tvs ctxt dict_ty))
536 HsParTy ty -> checkInstType ty
538 ty -> do dict_ty <- checkDictTy (L l ty)
539 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
541 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
542 checkDictTy (L spn ty) = check ty []
544 check (HsTyVar t) args | not (isRdrTyVar t)
545 = return (L spn (HsPredTy (HsClassP t args)))
546 check (HsAppTy l r) args = check (unLoc l) (r:args)
547 check (HsParTy t) args = check (unLoc t) args
548 check _ _ = parseError spn "Malformed instance header"
550 checkTParams :: Bool -- Type/data family
552 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
553 -- checkTParams checks the type parameters of a data/newtype declaration
554 -- There are two cases:
556 -- a) Vanilla data/newtype decl. In that case
557 -- - the type parameters should all be type variables
558 -- - they may have a kind annotation
560 -- b) Family data/newtype decl. In that case
561 -- - The type parameters may be arbitrary types
562 -- - We find the type-varaible binders by find the
563 -- free type vars of those types
564 -- - We make them all kind-sig-free binders (UserTyVar)
565 -- If there are kind sigs in the type parameters, they
566 -- will fix the binder's kind when we kind-check the
568 checkTParams is_family tparams
569 | not is_family -- Vanilla case (a)
570 = do { tyvars <- checkTyVars tparams
571 ; return (tyvars, Nothing) }
572 | otherwise -- Family case (b)
573 = do { let tyvars = [L l (UserTyVar tv)
574 | L l tv <- extractHsTysRdrTyVars tparams]
575 ; return (tyvars, Just tparams) }
577 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
578 -- Check whether the given list of type parameters are all type variables
579 -- (possibly with a kind signature). If the second argument is `False',
580 -- only type variables are allowed and we raise an error on encountering a
581 -- non-variable; otherwise, we allow non-variable arguments and return the
582 -- entire list of parameters.
583 checkTyVars tparms = mapM chk tparms
585 -- Check that the name space is correct!
586 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
587 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
588 chk (L l (HsTyVar tv))
589 | isRdrTyVar tv = return (L l (UserTyVar tv))
591 parseError l "Type found where type variable expected"
593 checkTyClHdr :: LHsType RdrName
594 -> P (Located RdrName, -- the head symbol (type or class name)
595 [LHsType RdrName]) -- parameters of head symbol
596 -- Well-formedness check and decomposition of type and class heads.
597 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
598 -- Int :*: Bool into (:*:, [Int, Bool])
599 -- returning the pieces
603 goL (L l ty) acc = go l ty acc
605 go l (HsTyVar tc) acc
606 | isRdrTc tc = return (L l tc, acc)
608 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
609 | isRdrTc tc = return (ltc, t1:t2:acc)
610 go _ (HsParTy ty) acc = goL ty acc
611 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
612 go l _ _ = parseError l "Malformed head of type or class declaration"
614 -- Check that associated type declarations of a class are all kind signatures.
616 checkKindSigs :: [LTyClDecl RdrName] -> P ()
617 checkKindSigs = mapM_ check
620 | isFamilyDecl tydecl
621 || isSynDecl tydecl = return ()
623 parseError l "Type declaration in a class must be a kind signature or synonym default"
625 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
629 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
630 = do ctx <- mapM checkPred ts
633 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
636 check (HsTyVar t) -- Empty context shows up as a unit type ()
637 | t == getRdrName unitTyCon = return (L l [])
640 = do p <- checkPred (L l t)
644 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
645 -- Watch out.. in ...deriving( Show )... we use checkPred on
646 -- the list of partially applied predicates in the deriving,
647 -- so there can be zero args.
648 checkPred (L spn (HsPredTy (HsIParam n ty)))
649 = return (L spn (HsIParam n ty))
653 checkl (L l ty) args = check l ty args
655 check _loc (HsPredTy pred@(HsEqualP _ _))
657 = return $ L spn pred
658 check _loc (HsTyVar t) args | not (isRdrTyVar t)
659 = return (L spn (HsClassP t args))
660 check _loc (HsAppTy l r) args = checkl l (r:args)
661 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
662 check _loc (HsParTy t) args = checkl t args
663 check loc _ _ = parseError loc
664 "malformed class assertion"
666 ---------------------------------------------------------------------------
667 -- Checking stand-alone deriving declarations
669 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
670 checkDerivDecl d@(L loc _) =
671 do stDerivOn <- extension standaloneDerivingEnabled
672 if stDerivOn then return d
673 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
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 { p <- checkAPat loc e; return (L loc p) }
732 checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
733 checkAPat loc e = case e of
734 EWildPat -> return (WildPat placeHolderType)
735 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
737 | otherwise -> 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 {}})))
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 plus_RDR, bang_RDR :: RdrName
799 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
800 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
802 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
803 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
804 ; return (fld { hsRecFieldArg = p }) }
806 patFail :: SrcSpan -> P a
807 patFail loc = parseError loc "Parse error in pattern"
810 ---------------------------------------------------------------------------
811 -- Check Equation Syntax
813 checkValDef :: LHsExpr RdrName
814 -> Maybe (LHsType RdrName)
815 -> Located (GRHSs RdrName)
816 -> P (HsBind RdrName)
818 checkValDef lhs (Just sig) grhss
819 -- x :: ty = rhs parses as a *pattern* binding
820 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
822 checkValDef lhs opt_sig grhss
823 = do { mb_fun <- isFunLhs lhs
825 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
826 fun is_infix pats opt_sig grhss
827 Nothing -> checkPatBind lhs grhss }
829 checkFunBind :: SrcSpan
833 -> Maybe (LHsType RdrName)
834 -> Located (GRHSs RdrName)
835 -> P (HsBind RdrName)
836 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
838 = parseErrorSDoc (getLoc fun)
839 (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
841 = do ps <- checkPatterns pats
842 let match_span = combineSrcSpans lhs_loc rhs_span
843 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
844 -- The span of the match covers the entire equation.
845 -- That isn't quite right, but it'll do for now.
847 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
848 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
849 makeFunBind fn is_infix ms
850 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
851 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
853 checkPatBind :: LHsExpr RdrName
854 -> Located (GRHSs RdrName)
855 -> P (HsBind RdrName)
856 checkPatBind lhs (L _ grhss)
857 = do { lhs <- checkPattern lhs
858 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
864 checkValSig (L l (HsVar v)) ty
865 | isUnqual v && not (isDataOcc (rdrNameOcc v))
866 = return (TypeSig (L l v) ty)
867 checkValSig (L l _) _
868 = parseError l "Invalid type signature"
873 -- The parser left-associates, so there should
874 -- not be any OpApps inside the e's
875 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
876 -- Splits (f ! g a b) into (f, [(! g), a, b])
877 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
878 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
880 (arg1,argns) = split_bang r_arg []
881 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
882 split_bang e es = (e,es)
883 splitBang _ = Nothing
885 isFunLhs :: LHsExpr RdrName
886 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
887 -- A variable binding is parsed as a FunBind.
888 -- Just (fun, is_infix, arg_pats) if e is a function LHS
890 -- The whole LHS is parsed as a single expression.
891 -- Any infix operators on the LHS will parse left-associatively
893 -- will parse (rather strangely) as
895 -- It's up to isFunLhs to sort out the mess
901 go (L loc (HsVar f)) es
902 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
903 go (L _ (HsApp f e)) es = go f (e:es)
904 go (L _ (HsPar e)) es@(_:_) = go e es
906 -- For infix function defns, there should be only one infix *function*
907 -- (though there may be infix *datacons* involved too). So we don't
908 -- need fixity info to figure out which function is being defined.
909 -- a `K1` b `op` c `K2` d
911 -- (a `K1` b) `op` (c `K2` d)
912 -- The renamer checks later that the precedences would yield such a parse.
914 -- There is a complication to deal with bang patterns.
916 -- ToDo: what about this?
917 -- x + 1 `op` y = ...
919 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
920 | Just (e',es') <- splitBang e
921 = do { bang_on <- extension bangPatEnabled
922 ; if bang_on then go e' (es' ++ es)
923 else return (Just (L loc' op, True, (l:r:es))) }
924 -- No bangs; behave just like the next case
925 | not (isRdrDataCon op) -- We have found the function!
926 = return (Just (L loc' op, True, (l:r:es)))
927 | otherwise -- Infix data con; keep going
928 = do { mb_l <- go l es
930 Just (op', True, j : k : es')
931 -> return (Just (op', True, j : op_app : es'))
933 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
934 _ -> return Nothing }
935 go _ _ = return Nothing
937 ---------------------------------------------------------------------------
938 -- Miscellaneous utilities
940 checkPrecP :: Located Int -> P Int
942 | 0 <= i && i <= maxPrecedence = return i
943 | otherwise = parseError l "Precedence out of range"
948 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
949 -> P (HsExpr RdrName)
951 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
952 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
953 mkRecConstrOrUpdate exp loc (fs,dd)
954 | null fs = parseError loc "Empty record update"
955 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
957 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
958 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
959 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
961 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
962 -- The Maybe is becuase the user can omit the activation spec (and usually does)
963 mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
965 mkInlineSpec Nothing match_info False = neverInlineSpec match_info
967 mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
969 -----------------------------------------------------------------------------
970 -- utilities for foreign declarations
972 -- supported calling conventions
974 data CallConv = CCall CCallConv -- ccall or stdcall
977 -- construct a foreign import declaration
981 -> (Located FastString, Located RdrName, LHsType RdrName)
982 -> P (HsDecl RdrName)
983 mkImport (CCall cconv) safety (L loc entity, v, ty)
984 | cconv == PrimCallConv = do
985 let funcTarget = CFunction (StaticTarget entity)
986 importSpec = CImport PrimCallConv safety nilFS funcTarget
987 return (ForD (ForeignImport v ty importSpec))
989 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
990 Nothing -> parseError loc "Malformed entity string"
991 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
992 mkImport (DNCall ) _ (entity, v, ty) = do
993 spec <- parseDImport entity
994 return $ ForD (ForeignImport v ty (DNImport spec))
996 -- the string "foo" is ambigous: either a header or a C identifier. The
997 -- C identifier case comes first in the alternatives below, so we pick
999 parseCImport :: CCallConv -> Safety -> FastString -> String
1000 -> Maybe ForeignImport
1001 parseCImport cconv safety nm str =
1002 listToMaybe $ map fst $ filter (null.snd) $
1003 readP_to_S parse str
1006 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
1007 string "wrapper" >> return (mk nilFS CWrapper),
1008 optional (string "static" >> skipSpaces) >>
1009 (mk nilFS <$> cimp nm) +++
1010 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
1013 mk = CImport cconv safety
1015 hdr_char c = isAscii c && (isAlphaNum c || c `elem` "._")
1016 id_char c = isAlphaNum c || c == '_'
1018 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1019 +++ ((CFunction . StaticTarget) <$> cid)
1022 (do c <- satisfy (\c -> isAlpha c || c == '_')
1023 cs <- many (satisfy id_char)
1024 return (mkFastString (c:cs)))
1028 -- Unravel a dotnet spec string.
1030 parseDImport :: Located FastString -> P DNCallSpec
1031 parseDImport (L loc entity) = parse0 comps
1033 comps = words (unpackFS entity)
1037 | x == "static" = parse1 True xs
1038 | otherwise = parse1 False (x:xs)
1041 parse1 isStatic (x:xs)
1042 | x == "method" = parse2 isStatic DNMethod xs
1043 | x == "field" = parse2 isStatic DNField xs
1044 | x == "ctor" = parse2 isStatic DNConstructor xs
1045 parse1 isStatic xs = parse2 isStatic DNMethod xs
1047 parse2 _ _ [] = d'oh
1048 parse2 isStatic kind (('[':x):xs) =
1051 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1053 parse2 isStatic kind xs = parse3 isStatic kind "" xs
1055 parse3 isStatic kind assem [x] =
1056 return (DNCallSpec isStatic kind assem x
1057 -- these will be filled in once known.
1058 (error "FFI-dotnet-args")
1059 (error "FFI-dotnet-result"))
1060 parse3 _ _ _ _ = d'oh
1062 d'oh = parseError loc "Malformed entity string"
1064 -- construct a foreign export declaration
1066 mkExport :: CallConv
1067 -> (Located FastString, Located RdrName, LHsType RdrName)
1068 -> P (HsDecl RdrName)
1069 mkExport (CCall cconv) (L _ entity, v, ty) = return $
1070 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1072 entity' | nullFS entity = mkExtName (unLoc v)
1073 | otherwise = entity
1074 mkExport DNCall (L _ _, v, _) =
1075 parseError (getLoc v){-TODO: not quite right-}
1076 "Foreign export is not yet supported for .NET"
1078 -- Supplying the ext_name in a foreign decl is optional; if it
1079 -- isn't there, the Haskell name is assumed. Note that no transformation
1080 -- of the Haskell name is then performed, so if you foreign export (++),
1081 -- it's external name will be "++". Too bad; it's important because we don't
1082 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1084 mkExtName :: RdrName -> CLabelString
1085 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1089 -----------------------------------------------------------------------------
1093 parseError :: SrcSpan -> String -> P a
1094 parseError span s = parseErrorSDoc span (text s)
1096 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1097 parseErrorSDoc span s = failSpanMsgP span s