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 )
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 )
75 import OrdList ( OrdList, fromOL )
76 import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
81 import Control.Applicative ((<$>))
82 import Text.ParserCombinators.ReadP as ReadP
83 import Data.List ( nubBy )
84 import Data.Char ( isAscii, isAlphaNum, isAlpha )
86 #include "HsVersions.h"
90 %************************************************************************
92 \subsection{A few functions over HsSyn at RdrName}
94 %************************************************************************
96 extractHsTyRdrNames finds the free variables of a HsType
97 It's used when making the for-alls explicit.
100 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
101 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
103 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
104 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
106 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
107 -- This one takes the context and tau-part of a
108 -- sigma type and returns their free type variables
109 extractHsRhoRdrTyVars ctxt ty
110 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
112 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
113 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
115 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
116 extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
117 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
118 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
120 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
121 extract_ltys tys acc = foldr extract_lty acc tys
123 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
124 extract_lty (L loc ty) acc
126 HsTyVar tv -> extract_tv loc tv acc
127 HsBangTy _ ty -> extract_lty ty acc
128 HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
129 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
130 HsListTy ty -> extract_lty ty acc
131 HsPArrTy ty -> extract_lty ty acc
132 HsTupleTy _ tys -> extract_ltys tys acc
133 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
134 HsPredTy p -> extract_pred p acc
135 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
136 HsParTy ty -> extract_lty ty acc
138 HsSpliceTy _ -> acc -- Type splices mention no type variables
139 HsKindSig ty _ -> extract_lty ty acc
140 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
141 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
142 extract_lctxt cx (extract_lty ty []))
144 locals = hsLTyVarNames tvs
145 HsDocTy ty _ -> extract_lty ty acc
147 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
148 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
151 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
152 -- Get the type variables out of the type patterns in a bunch of
153 -- possibly-generic bindings in a class declaration
154 extractGenericPatTyVars binds
155 = nubBy eqLocated (foldrBag get [] binds)
157 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
160 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
165 %************************************************************************
167 \subsection{Construction functions for Rdr stuff}
169 %************************************************************************
171 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
172 by deriving them from the name of the class. We fill in the names for the
173 tycon and datacon corresponding to the class, by deriving them from the
174 name of the class itself. This saves recording the names in the interface
175 file (which would be equally good).
177 Similarly for mkConDecl, mkClassOpSig and default-method names.
179 *** See "THE NAMING STORY" in HsDecls ****
182 mkClassDecl :: SrcSpan
183 -> Located (LHsContext RdrName, LHsType RdrName)
184 -> Located [Located (FunDep RdrName)]
185 -> Located (OrdList (LHsDecl RdrName))
186 -> P (LTyClDecl RdrName)
188 mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
189 = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
190 ; (cls, tparams) <- checkTyClHdr tycl_hdr
191 ; tyvars <- checkTyVars tparams -- Only type vars allowed
193 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
194 tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
195 tcdATs = ats, tcdDocs = docs })) }
199 -> Bool -- True <=> data family instance
200 -> Located (LHsContext RdrName, LHsType RdrName)
202 -> [LConDecl RdrName]
203 -> Maybe [LHsType RdrName]
204 -> P (LTyClDecl RdrName)
205 mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
206 = do { (tc, tparams) <- checkTyClHdr tycl_hdr
208 ; (tyvars, typats) <- checkTParams is_family tparams
209 ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
210 tcdTyVars = tyvars, tcdTyPats = typats,
212 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
214 mkTySynonym :: SrcSpan
215 -> Bool -- True <=> type family instances
216 -> LHsType RdrName -- LHS
217 -> LHsType RdrName -- RHS
218 -> P (LTyClDecl RdrName)
219 mkTySynonym loc is_family lhs rhs
220 = do { (tc, tparams) <- checkTyClHdr lhs
221 ; (tyvars, typats) <- checkTParams is_family tparams
222 ; return (L loc (TySynonym tc tyvars typats rhs)) }
224 mkTyFamily :: SrcSpan
226 -> LHsType RdrName -- LHS
227 -> Maybe Kind -- Optional kind signature
228 -> P (LTyClDecl RdrName)
229 mkTyFamily loc flavour lhs ksig
230 = do { (tc, tparams) <- checkTyClHdr lhs
231 ; tyvars <- checkTyVars tparams
232 ; return (L loc (TyFamily flavour tc tyvars ksig)) }
235 %************************************************************************
237 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
239 %************************************************************************
241 Function definitions are restructured here. Each is assumed to be recursive
242 initially, and non recursive definitions are discovered by the dependency
247 -- | Groups together bindings for a single function
248 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
249 cvTopDecls decls = go (fromOL decls)
251 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
253 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
254 where (L l' b', ds') = getMonoBind (L l b) ds
255 go (d : ds) = d : go ds
257 -- Declaration list may only contain value bindings and signatures.
258 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
260 = case cvBindsAndSigs binding of
261 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
264 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
265 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
266 -- Input decls contain just value bindings and signatures
267 -- and in case of class or instance declarations also
268 -- associated type declarations. They might also contain Haddock comments.
269 cvBindsAndSigs fb = go (fromOL fb)
271 go [] = (emptyBag, [], [], [])
272 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
273 where (bs, ss, ts, docs) = go ds
274 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
275 where (b', ds') = getMonoBind (L l b) ds
276 (bs, ss, ts, docs) = go ds'
277 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
278 where (bs, ss, ts, docs) = go ds
279 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
280 where (bs, ss, ts, docs) = go ds
281 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
283 -----------------------------------------------------------------------------
284 -- Group function bindings into equation groups
286 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
287 -> (LHsBind RdrName, [LHsDecl RdrName])
288 -- Suppose (b',ds') = getMonoBind b ds
289 -- ds is a list of parsed bindings
290 -- b is a MonoBinds that has just been read off the front
292 -- Then b' is the result of grouping more equations from ds that
293 -- belong with b into a single MonoBinds, and ds' is the depleted
294 -- list of parsed bindings.
296 -- All Haddock comments between equations inside the group are
299 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
301 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
302 fun_matches = MatchGroup mtchs1 _ })) binds
304 = go is_infix1 mtchs1 loc1 binds []
306 go is_infix mtchs loc
307 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
308 fun_matches = MatchGroup mtchs2 _ })) : binds) _
309 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
310 (combineSrcSpans loc loc2) binds []
311 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
312 = let doc_decls' = doc_decl : doc_decls
313 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
314 go is_infix mtchs loc binds doc_decls
315 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
316 -- Reverse the final matches, to get it back in the right order
317 -- Do the same thing with the trailing doc comments
319 getMonoBind bind binds = (bind, binds)
321 has_args :: [LMatch RdrName] -> Bool
322 has_args [] = panic "RdrHsSyn:has_args"
323 has_args ((L _ (Match args _ _)) : _) = not (null args)
324 -- Don't group together FunBinds if they have
325 -- no arguments. This is necessary now that variable bindings
326 -- with no arguments are now treated as FunBinds rather
327 -- than pattern bindings (tests/rename/should_fail/rnfail002).
331 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
332 findSplice ds = addl emptyRdrGroup ds
334 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
335 -- Turn the body of a [d| ... |] into a HsGroup
336 -- There should be no splices in the "..."
337 checkDecBrGroup decls
338 = case addl emptyRdrGroup decls of
339 (group, Nothing) -> return group
340 (_, Just (SpliceDecl (L loc _), _)) ->
341 parseError loc "Declaration splices are not permitted inside declaration brackets"
342 -- Why not? See Section 7.3 of the TH paper.
344 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
345 -- This stuff reverses the declarations (again) but it doesn't matter
348 addl gp [] = (gp, Nothing)
349 addl gp (L l d : ds) = add gp l d ds
352 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
353 -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
355 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
357 -- Class declarations: pull out the fixity signatures to the top
358 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
361 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
362 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
364 addl (gp { hs_tyclds = L l d : ts }) ds
366 -- Signatures: fixity sigs go a different place than all others
367 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
368 = addl (gp {hs_fixds = L l f : ts}) ds
369 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
370 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
372 -- Value declarations: use add_bind
373 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
374 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
376 -- The rest are routine
377 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
378 = addl (gp { hs_instds = L l d : ts }) ds
379 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
380 = addl (gp { hs_derivds = L l d : ts }) ds
381 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
382 = addl (gp { hs_defds = L l d : ts }) ds
383 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
384 = addl (gp { hs_fords = L l d : ts }) ds
385 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
386 = addl (gp { hs_warnds = L l d : ts }) ds
387 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
388 = addl (gp { hs_annds = L l d : ts }) ds
389 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
390 = addl (gp { hs_ruleds = L l d : ts }) ds
393 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
395 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
396 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
397 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
399 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
400 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
401 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
404 %************************************************************************
406 \subsection[PrefixToHS-utils]{Utilities for conversion}
408 %************************************************************************
412 -----------------------------------------------------------------------------
415 -- When parsing data declarations, we sometimes inadvertently parse
416 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
417 -- This function splits up the type application, adds any pending
418 -- arguments, and converts the type constructor back into a data constructor.
420 splitCon :: LHsType RdrName
421 -> P (Located RdrName, HsConDeclDetails RdrName)
422 -- This gets given a "type" that should look like
424 -- or C { x::Int, y::Bool }
425 -- and returns the pieces
429 split (L _ (HsAppTy t u)) ts = split t (u : ts)
430 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
431 return (data_con, mk_rest ts)
432 split (L l _) _ = parseError l "parse error in data/newtype declaration"
434 mk_rest [L _ (HsRecTy flds)] = RecCon flds
435 mk_rest ts = PrefixCon ts
437 mkDeprecatedGadtRecordDecl :: SrcSpan
439 -> [ConDeclField RdrName]
441 -> P (LConDecl RdrName)
442 -- This one uses the deprecated syntax
443 -- C { x,y ::Int } :: T a b
444 -- We give it a RecCon details right away
445 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
446 = do { data_con <- tyConToDataCon con_loc con
447 ; return (L loc (ConDecl { con_old_rec = True
448 , con_name = data_con
449 , con_explicit = Implicit
452 , con_details = RecCon flds
453 , con_res = ResTyGADT res_ty
454 , con_doc = Nothing })) }
456 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
457 -> LHsContext RdrName -> HsConDeclDetails RdrName
460 mkSimpleConDecl name qvars cxt details
461 = ConDecl { con_old_rec = False
463 , con_explicit = Explicit
466 , con_details = details
468 , con_doc = Nothing }
470 mkGadtDecl :: [Located RdrName]
471 -> LHsType RdrName -- Always a HsForAllTy
473 -- We allow C,D :: ty
474 -- and expand it as if it had been
476 -- (Just like type signatures in general.)
477 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
478 = [mk_gadt_con name | name <- names]
480 (details, res_ty) -- See Note [Sorting out the result type]
482 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
483 _other -> (PrefixCon [], tau)
486 = ConDecl { con_old_rec = False
491 , con_details = details
492 , con_res = ResTyGADT res_ty
493 , con_doc = Nothing }
494 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
496 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
497 tyConToDataCon loc tc
498 | isTcOcc (rdrNameOcc tc)
499 = return (L loc (setRdrNameSpace tc srcDataName))
501 = parseErrorSDoc loc (msg $$ extra)
503 msg = text "Not a data constructor:" <+> quotes (ppr tc)
504 extra | tc == forall_tv_RDR
505 = text "Perhaps you intended to use -XExistentialQuantification"
509 Note [Sorting out the result type]
510 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
511 In a GADT declaration which is not a record, we put the whole constr
512 type into the ResTyGADT for now; the renamer will unravel it once it
513 has sorted out operator fixities. Consider for example
514 C :: a :*: b -> a :*: b -> a :+: b
515 Initially this type will parse as
516 a :*: (b -> (a :*: (b -> (a :+: b))))
518 so it's hard to split up the arguments until we've done the precedence
519 resolution (in the renamer) On the other hand, for a record
520 { x,y :: Int } -> a :*: b
521 there is no doubt. AND we need to sort records out so that
522 we can bring x,y into scope. So:
523 * For PrefixCon we keep all the args in the ResTyGADT
524 * For RecCon we do not
527 ----------------------------------------------------------------------------
528 -- Various Syntactic Checks
530 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
531 checkInstType (L l t)
533 HsForAllTy exp tvs ctxt ty -> do
534 dict_ty <- checkDictTy ty
535 return (L l (HsForAllTy exp tvs ctxt dict_ty))
537 HsParTy ty -> checkInstType ty
539 ty -> do dict_ty <- checkDictTy (L l ty)
540 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
542 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
543 checkDictTy (L spn ty) = check ty []
545 check (HsTyVar t) args | not (isRdrTyVar t)
546 = return (L spn (HsPredTy (HsClassP t args)))
547 check (HsAppTy l r) args = check (unLoc l) (r:args)
548 check (HsParTy t) args = check (unLoc t) args
549 check _ _ = parseError spn "Malformed instance header"
551 checkTParams :: Bool -- Type/data family
553 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
554 -- checkTParams checks the type parameters of a data/newtype declaration
555 -- There are two cases:
557 -- a) Vanilla data/newtype decl. In that case
558 -- - the type parameters should all be type variables
559 -- - they may have a kind annotation
561 -- b) Family data/newtype decl. In that case
562 -- - The type parameters may be arbitrary types
563 -- - We find the type-varaible binders by find the
564 -- free type vars of those types
565 -- - We make them all kind-sig-free binders (UserTyVar)
566 -- If there are kind sigs in the type parameters, they
567 -- will fix the binder's kind when we kind-check the
569 checkTParams is_family tparams
570 | not is_family -- Vanilla case (a)
571 = do { tyvars <- checkTyVars tparams
572 ; return (tyvars, Nothing) }
573 | otherwise -- Family case (b)
574 = do { let tyvars = [L l (UserTyVar tv)
575 | L l tv <- extractHsTysRdrTyVars tparams]
576 ; return (tyvars, Just tparams) }
578 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
579 -- Check whether the given list of type parameters are all type variables
580 -- (possibly with a kind signature). If the second argument is `False',
581 -- only type variables are allowed and we raise an error on encountering a
582 -- non-variable; otherwise, we allow non-variable arguments and return the
583 -- entire list of parameters.
584 checkTyVars tparms = mapM chk tparms
586 -- Check that the name space is correct!
587 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
588 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
589 chk (L l (HsTyVar tv))
590 | isRdrTyVar tv = return (L l (UserTyVar tv))
592 parseError l "Type found where type variable expected"
594 checkTyClHdr :: LHsType RdrName
595 -> P (Located RdrName, -- the head symbol (type or class name)
596 [LHsType RdrName]) -- parameters of head symbol
597 -- Well-formedness check and decomposition of type and class heads.
598 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
599 -- Int :*: Bool into (:*:, [Int, Bool])
600 -- returning the pieces
604 goL (L l ty) acc = go l ty acc
606 go l (HsTyVar tc) acc
607 | isRdrTc tc = return (L l tc, acc)
609 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
610 | isRdrTc tc = return (ltc, t1:t2:acc)
611 go _ (HsParTy ty) acc = goL ty acc
612 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
613 go l _ _ = parseError l "Malformed head of type or class declaration"
615 -- Check that associated type declarations of a class are all kind signatures.
617 checkKindSigs :: [LTyClDecl RdrName] -> P ()
618 checkKindSigs = mapM_ check
621 | isFamilyDecl tydecl
622 || isSynDecl tydecl = return ()
624 parseError l "Type declaration in a class must be a kind signature or synonym default"
626 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
630 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
631 = do ctx <- mapM checkPred ts
634 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
637 check (HsTyVar t) -- Empty context shows up as a unit type ()
638 | t == getRdrName unitTyCon = return (L l [])
641 = do p <- checkPred (L l t)
645 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
646 -- Watch out.. in ...deriving( Show )... we use checkPred on
647 -- the list of partially applied predicates in the deriving,
648 -- so there can be zero args.
649 checkPred (L spn (HsPredTy (HsIParam n ty)))
650 = return (L spn (HsIParam n ty))
654 checkl (L l ty) args = check l ty args
656 check _loc (HsPredTy pred@(HsEqualP _ _))
658 = return $ L spn pred
659 check _loc (HsTyVar t) args | not (isRdrTyVar t)
660 = return (L spn (HsClassP t args))
661 check _loc (HsAppTy l r) args = checkl l (r:args)
662 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
663 check _loc (HsParTy t) args = checkl t args
664 check loc _ _ = parseError loc
665 "malformed class assertion"
667 ---------------------------------------------------------------------------
668 -- Checking stand-alone deriving declarations
670 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
671 checkDerivDecl d@(L loc _) =
672 do stDerivOn <- extension standaloneDerivingEnabled
673 if stDerivOn then return d
674 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
676 ---------------------------------------------------------------------------
677 -- Checking statements in a do-expression
678 -- We parse do { e1 ; e2 ; }
679 -- as [ExprStmt e1, ExprStmt e2]
680 -- checkDo (a) checks that the last thing is an ExprStmt
681 -- (b) returns it separately
682 -- same comments apply for mdo as well
684 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
686 checkDo = checkDoMDo "a " "'do'"
687 checkMDo = checkDoMDo "an " "'mdo'"
689 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
690 checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
691 checkDoMDo pre nm _ ss = do
694 check [] = panic "RdrHsSyn:checkDoMDo"
695 check [L _ (ExprStmt e _ _)] = return ([], e)
696 check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
697 " construct must be an expression")
702 -- -------------------------------------------------------------------------
703 -- Checking Patterns.
705 -- We parse patterns as expressions and check for valid patterns below,
706 -- converting the expression into a pattern at the same time.
708 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
709 checkPattern e = checkLPat e
711 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
712 checkPatterns es = mapM checkPattern es
714 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
715 checkLPat e@(L l _) = checkPat l e []
717 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
718 checkPat loc (L l (HsVar c)) args
719 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
720 checkPat loc e args -- OK to let this happen even if bang-patterns
721 -- are not enabled, because there is no valid
722 -- non-bang-pattern parse of (C ! e)
723 | Just (e', args') <- splitBang e
724 = do { args'' <- checkPatterns args'
725 ; checkPat loc e' (args'' ++ args) }
726 checkPat loc (L _ (HsApp f x)) args
727 = do { x <- checkLPat x; checkPat loc f (x:args) }
728 checkPat loc (L _ e) []
729 = do { pState <- getPState
730 ; p <- checkAPat (dflags pState) loc e
735 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
736 checkAPat dynflags loc e = case e of
737 EWildPat -> return (WildPat placeHolderType)
738 HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
740 | otherwise -> return (VarPat x)
741 HsLit l -> return (LitPat l)
743 -- Overloaded numeric patterns (e.g. f 0 x = x)
744 -- Negation is recorded separately, so that the literal is zero or +ve
745 -- NB. Negative *primitive* literals are already handled by the lexer
746 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
747 NegApp (L _ (HsOverLit pos_lit)) _
748 -> return (mkNPat pos_lit (Just noSyntaxExpr))
750 SectionR (L _ (HsVar bang)) e -- (! x)
752 -> do { bang_on <- extension bangPatEnabled
753 ; if bang_on then checkLPat e >>= (return . BangPat)
754 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
756 ELazyPat e -> checkLPat e >>= (return . LazyPat)
757 EAsPat n e -> checkLPat e >>= (return . AsPat n)
758 -- view pattern is well-formed if the pattern is
759 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
760 ExprWithTySig e t -> do e <- checkLPat e
761 -- Pattern signatures are parsed as sigtypes,
762 -- but they aren't explicit forall points. Hence
763 -- we have to remove the implicit forall here.
765 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
767 return (SigPatIn e t')
770 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
771 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
772 | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
773 -> return (mkNPlusKPat (L nloc n) lit)
775 OpApp l op _fix r -> do l <- checkLPat l
778 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
779 -> return (ConPatIn (L cl c) (InfixCon l r))
782 HsPar e -> checkLPat e >>= (return . ParPat)
783 ExplicitList _ es -> do ps <- mapM checkLPat es
784 return (ListPat ps placeHolderType)
785 ExplicitPArr _ es -> do ps <- mapM checkLPat es
786 return (PArrPat ps placeHolderType)
789 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
790 return (TuplePat ps b placeHolderType)
791 | otherwise -> parseError loc "Illegal tuple section in pattern"
793 RecordCon c _ (HsRecFields fs dd)
794 -> do fs <- mapM checkPatField fs
795 return (ConPatIn c (RecCon (HsRecFields fs dd)))
796 HsQuasiQuoteE q -> return (QuasiQuotePat q)
798 HsType ty -> return (TypePat ty)
801 plus_RDR, bang_RDR :: RdrName
802 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
803 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
805 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
806 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
807 ; return (fld { hsRecFieldArg = p }) }
809 patFail :: SrcSpan -> P a
810 patFail loc = parseError loc "Parse error in pattern"
813 ---------------------------------------------------------------------------
814 -- Check Equation Syntax
816 checkValDef :: LHsExpr RdrName
817 -> Maybe (LHsType RdrName)
818 -> Located (GRHSs RdrName)
819 -> P (HsBind RdrName)
821 checkValDef lhs (Just sig) grhss
822 -- x :: ty = rhs parses as a *pattern* binding
823 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
825 checkValDef lhs opt_sig grhss
826 = do { mb_fun <- isFunLhs lhs
828 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
829 fun is_infix pats opt_sig grhss
830 Nothing -> checkPatBind lhs grhss }
832 checkFunBind :: SrcSpan
836 -> Maybe (LHsType RdrName)
837 -> Located (GRHSs RdrName)
838 -> P (HsBind RdrName)
839 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
841 = parseErrorSDoc (getLoc fun)
842 (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
844 = do ps <- checkPatterns pats
845 let match_span = combineSrcSpans lhs_loc rhs_span
846 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
847 -- The span of the match covers the entire equation.
848 -- That isn't quite right, but it'll do for now.
850 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
851 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
852 makeFunBind fn is_infix ms
853 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
854 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
856 checkPatBind :: LHsExpr RdrName
857 -> Located (GRHSs RdrName)
858 -> P (HsBind RdrName)
859 checkPatBind lhs (L _ grhss)
860 = do { lhs <- checkPattern lhs
861 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
867 checkValSig (L l (HsVar v)) ty
868 | isUnqual v && not (isDataOcc (rdrNameOcc v))
869 = return (TypeSig (L l v) ty)
870 checkValSig (L l _) _
871 = parseError l "Invalid type signature"
876 -- The parser left-associates, so there should
877 -- not be any OpApps inside the e's
878 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
879 -- Splits (f ! g a b) into (f, [(! g), a, b])
880 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
881 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
883 (arg1,argns) = split_bang r_arg []
884 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
885 split_bang e es = (e,es)
886 splitBang _ = Nothing
888 isFunLhs :: LHsExpr RdrName
889 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
890 -- A variable binding is parsed as a FunBind.
891 -- Just (fun, is_infix, arg_pats) if e is a function LHS
893 -- The whole LHS is parsed as a single expression.
894 -- Any infix operators on the LHS will parse left-associatively
896 -- will parse (rather strangely) as
898 -- It's up to isFunLhs to sort out the mess
904 go (L loc (HsVar f)) es
905 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
906 go (L _ (HsApp f e)) es = go f (e:es)
907 go (L _ (HsPar e)) es@(_:_) = go e es
909 -- For infix function defns, there should be only one infix *function*
910 -- (though there may be infix *datacons* involved too). So we don't
911 -- need fixity info to figure out which function is being defined.
912 -- a `K1` b `op` c `K2` d
914 -- (a `K1` b) `op` (c `K2` d)
915 -- The renamer checks later that the precedences would yield such a parse.
917 -- There is a complication to deal with bang patterns.
919 -- ToDo: what about this?
920 -- x + 1 `op` y = ...
922 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
923 | Just (e',es') <- splitBang e
924 = do { bang_on <- extension bangPatEnabled
925 ; if bang_on then go e' (es' ++ es)
926 else return (Just (L loc' op, True, (l:r:es))) }
927 -- No bangs; behave just like the next case
928 | not (isRdrDataCon op) -- We have found the function!
929 = return (Just (L loc' op, True, (l:r:es)))
930 | otherwise -- Infix data con; keep going
931 = do { mb_l <- go l es
933 Just (op', True, j : k : es')
934 -> return (Just (op', True, j : op_app : es'))
936 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
937 _ -> return Nothing }
938 go _ _ = return Nothing
940 ---------------------------------------------------------------------------
941 -- Miscellaneous utilities
943 checkPrecP :: Located Int -> P Int
945 | 0 <= i && i <= maxPrecedence = return i
946 | otherwise = parseError l "Precedence out of range"
951 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
952 -> P (HsExpr RdrName)
954 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
955 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
956 mkRecConstrOrUpdate exp loc (fs,dd)
957 | null fs = parseError loc "Empty record update"
958 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
960 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
961 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
962 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
964 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
965 -- The Maybe is becuase the user can omit the activation spec (and usually does)
966 mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
968 mkInlineSpec Nothing match_info False = neverInlineSpec match_info
970 mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
972 -----------------------------------------------------------------------------
973 -- utilities for foreign declarations
975 -- supported calling conventions
977 data CallConv = CCall CCallConv -- ccall or stdcall
980 -- construct a foreign import declaration
984 -> (Located FastString, Located RdrName, LHsType RdrName)
985 -> P (HsDecl RdrName)
986 mkImport (CCall cconv) safety (L loc entity, v, ty)
987 | cconv == PrimCallConv = do
988 let funcTarget = CFunction (StaticTarget entity)
989 importSpec = CImport PrimCallConv safety nilFS funcTarget
990 return (ForD (ForeignImport v ty importSpec))
992 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
993 Nothing -> parseError loc "Malformed entity string"
994 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
995 mkImport (DNCall ) _ (entity, v, ty) = do
996 spec <- parseDImport entity
997 return $ ForD (ForeignImport v ty (DNImport spec))
999 -- the string "foo" is ambigous: either a header or a C identifier. The
1000 -- C identifier case comes first in the alternatives below, so we pick
1002 parseCImport :: CCallConv -> Safety -> FastString -> String
1003 -> Maybe ForeignImport
1004 parseCImport cconv safety nm str =
1005 listToMaybe $ map fst $ filter (null.snd) $
1006 readP_to_S parse str
1009 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
1010 string "wrapper" >> return (mk nilFS CWrapper),
1011 optional (string "static" >> skipSpaces) >>
1012 (mk nilFS <$> cimp nm) +++
1013 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
1016 mk = CImport cconv safety
1018 hdr_char c = isAscii c && (isAlphaNum c || c `elem` "._")
1019 id_char c = isAlphaNum c || c == '_'
1021 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1022 +++ ((CFunction . StaticTarget) <$> cid)
1025 (do c <- satisfy (\c -> isAlpha c || c == '_')
1026 cs <- many (satisfy id_char)
1027 return (mkFastString (c:cs)))
1031 -- Unravel a dotnet spec string.
1033 parseDImport :: Located FastString -> P DNCallSpec
1034 parseDImport (L loc entity) = parse0 comps
1036 comps = words (unpackFS entity)
1040 | x == "static" = parse1 True xs
1041 | otherwise = parse1 False (x:xs)
1044 parse1 isStatic (x:xs)
1045 | x == "method" = parse2 isStatic DNMethod xs
1046 | x == "field" = parse2 isStatic DNField xs
1047 | x == "ctor" = parse2 isStatic DNConstructor xs
1048 parse1 isStatic xs = parse2 isStatic DNMethod xs
1050 parse2 _ _ [] = d'oh
1051 parse2 isStatic kind (('[':x):xs) =
1054 vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1056 parse2 isStatic kind xs = parse3 isStatic kind "" xs
1058 parse3 isStatic kind assem [x] =
1059 return (DNCallSpec isStatic kind assem x
1060 -- these will be filled in once known.
1061 (error "FFI-dotnet-args")
1062 (error "FFI-dotnet-result"))
1063 parse3 _ _ _ _ = d'oh
1065 d'oh = parseError loc "Malformed entity string"
1067 -- construct a foreign export declaration
1069 mkExport :: CallConv
1070 -> (Located FastString, Located RdrName, LHsType RdrName)
1071 -> P (HsDecl RdrName)
1072 mkExport (CCall cconv) (L _ entity, v, ty) = return $
1073 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1075 entity' | nullFS entity = mkExtName (unLoc v)
1076 | otherwise = entity
1077 mkExport DNCall (L _ _, v, _) =
1078 parseError (getLoc v){-TODO: not quite right-}
1079 "Foreign export is not yet supported for .NET"
1081 -- Supplying the ext_name in a foreign decl is optional; if it
1082 -- isn't there, the Haskell name is assumed. Note that no transformation
1083 -- of the Haskell name is then performed, so if you foreign export (++),
1084 -- it's external name will be "++". Too bad; it's important because we don't
1085 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1087 mkExtName :: RdrName -> CLabelString
1088 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1092 -----------------------------------------------------------------------------
1096 parseError :: SrcSpan -> String -> P a
1097 parseError span s = parseErrorSDoc span (text s)
1099 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1100 parseErrorSDoc span s = failSpanMsgP span s