2 % (c) The University of Glasgow, 1996-2003
4 Functions over HsSyn specialised to RdrName.
9 extractHsRhoRdrTyVars, extractGenericPatTyVars,
12 mkHsIntegral, mkHsFractional, mkHsIsString,
13 mkHsDo, mkHsSplice, mkTopSpliceDecl,
14 mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
15 splitCon, mkInlinePragma,
16 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
23 -- Stuff to do with Foreign declarations
27 mkExtName, -- RdrName -> CLabelString
28 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
30 mkDeprecatedGadtRecordDecl,
32 -- Bunch of functions in the parser monad for
33 -- checking and constructing values
34 checkPrecP, -- Int -> P Int
35 checkContext, -- HsType -> P HsContext
36 checkPred, -- HsType -> P HsPred
37 checkTyVars, -- [LHsType RdrName] -> P ()
38 checkKindSigs, -- [LTyClDecl RdrName] -> P ()
39 checkInstType, -- HsType -> P HsType
40 checkPattern, -- HsExp -> P HsPat
42 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
43 checkDo, -- [Stmt] -> P [Stmt]
44 checkMDo, -- [Stmt] -> P [Stmt]
45 checkMonadComp, -- P (HsStmtContext RdrName)
46 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
47 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
53 import HsSyn -- Lots of it
54 import Class ( FunDep )
55 import TypeRep ( Kind )
56 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
57 isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
59 import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo,
60 InlinePragma(..), InlineSpec(..) )
62 import TysWiredIn ( unitTyCon )
64 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
66 import PrelNames ( forall_tv_RDR )
69 import OrdList ( OrdList, fromOL )
70 import Bag ( Bag, emptyBag, consBag, foldrBag )
75 import Control.Applicative ((<$>))
77 import Text.ParserCombinators.ReadP as ReadP
78 import Data.List ( nubBy )
81 #include "HsVersions.h"
85 %************************************************************************
87 \subsection{A few functions over HsSyn at RdrName}
89 %************************************************************************
91 extractHsTyRdrNames finds the free variables of a HsType
92 It's used when making the for-alls explicit.
95 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
96 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
98 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
99 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
101 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
102 -- This one takes the context and tau-part of a
103 -- sigma type and returns their free type variables
104 extractHsRhoRdrTyVars ctxt ty
105 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
107 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
108 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
110 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
111 extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
112 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
113 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
115 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
116 extract_ltys tys acc = foldr extract_lty acc tys
118 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
119 extract_lty (L loc ty) acc
121 HsTyVar tv -> extract_tv loc tv acc
122 HsBangTy _ ty -> extract_lty ty acc
123 HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
124 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
125 HsListTy ty -> extract_lty ty acc
126 HsPArrTy ty -> extract_lty ty acc
127 HsTupleTy _ tys -> extract_ltys tys acc
128 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
129 HsPredTy p -> extract_pred p acc
130 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
131 HsParTy ty -> extract_lty ty acc
133 HsCoreTy {} -> acc -- The type is closed
134 HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
135 HsSpliceTy {} -> acc -- Type splices mention no type variables
136 HsKindSig ty _ -> extract_lty ty acc
137 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
138 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
139 extract_lctxt cx (extract_lty ty []))
141 locals = hsLTyVarNames tvs
142 HsDocTy ty _ -> extract_lty ty acc
144 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
145 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
148 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
149 -- Get the type variables out of the type patterns in a bunch of
150 -- possibly-generic bindings in a class declaration
151 extractGenericPatTyVars binds
152 = nubBy eqLocated (foldrBag get [] binds)
154 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
157 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
162 %************************************************************************
164 \subsection{Construction functions for Rdr stuff}
166 %************************************************************************
168 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
169 by deriving them from the name of the class. We fill in the names for the
170 tycon and datacon corresponding to the class, by deriving them from the
171 name of the class itself. This saves recording the names in the interface
172 file (which would be equally good).
174 Similarly for mkConDecl, mkClassOpSig and default-method names.
176 *** See "THE NAMING STORY" in HsDecls ****
179 mkClassDecl :: SrcSpan
180 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
181 -> Located [Located (FunDep RdrName)]
182 -> Located (OrdList (LHsDecl RdrName))
183 -> P (LTyClDecl RdrName)
185 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
186 = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
187 ; let cxt = fromMaybe (noLoc []) mcxt
188 ; (cls, tparams) <- checkTyClHdr tycl_hdr
189 ; tyvars <- checkTyVars tparams -- Only type vars allowed
191 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
192 tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
193 tcdATs = ats, tcdDocs = docs })) }
197 -> Bool -- True <=> data family instance
198 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
200 -> [LConDecl RdrName]
201 -> Maybe [LHsType RdrName]
202 -> P (LTyClDecl RdrName)
203 mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
204 = do { (tc, tparams) <- checkTyClHdr tycl_hdr
206 ; checkDatatypeContext mcxt
207 ; let cxt = fromMaybe (noLoc []) mcxt
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)) }
234 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
236 -- [pads| ... ] then return a QuasiQuoteD
237 -- $(e) then return a SpliceD
238 -- but if she wrote, say,
239 -- f x then behave as if she'd written $(f x)
241 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq
242 mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit)
243 mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit)
246 %************************************************************************
248 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
250 %************************************************************************
252 Function definitions are restructured here. Each is assumed to be recursive
253 initially, and non recursive definitions are discovered by the dependency
258 -- | Groups together bindings for a single function
259 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
260 cvTopDecls decls = go (fromOL decls)
262 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
264 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
265 where (L l' b', ds') = getMonoBind (L l b) ds
266 go (d : ds) = d : go ds
268 -- Declaration list may only contain value bindings and signatures.
269 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
271 = case cvBindsAndSigs binding of
272 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
275 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
276 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
277 -- Input decls contain just value bindings and signatures
278 -- and in case of class or instance declarations also
279 -- associated type declarations. They might also contain Haddock comments.
280 cvBindsAndSigs fb = go (fromOL fb)
282 go [] = (emptyBag, [], [], [])
283 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
284 where (bs, ss, ts, docs) = go ds
285 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
286 where (b', ds') = getMonoBind (L l b) ds
287 (bs, ss, ts, docs) = go ds'
288 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
289 where (bs, ss, ts, docs) = go ds
290 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
291 where (bs, ss, ts, docs) = go ds
292 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
294 -----------------------------------------------------------------------------
295 -- Group function bindings into equation groups
297 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
298 -> (LHsBind RdrName, [LHsDecl RdrName])
299 -- Suppose (b',ds') = getMonoBind b ds
300 -- ds is a list of parsed bindings
301 -- b is a MonoBinds that has just been read off the front
303 -- Then b' is the result of grouping more equations from ds that
304 -- belong with b into a single MonoBinds, and ds' is the depleted
305 -- list of parsed bindings.
307 -- All Haddock comments between equations inside the group are
310 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
312 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
313 fun_matches = MatchGroup mtchs1 _ })) binds
315 = go is_infix1 mtchs1 loc1 binds []
317 go is_infix mtchs loc
318 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
319 fun_matches = MatchGroup mtchs2 _ })) : binds) _
320 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
321 (combineSrcSpans loc loc2) binds []
322 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
323 = let doc_decls' = doc_decl : doc_decls
324 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
325 go is_infix mtchs loc binds doc_decls
326 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
327 -- Reverse the final matches, to get it back in the right order
328 -- Do the same thing with the trailing doc comments
330 getMonoBind bind binds = (bind, binds)
332 has_args :: [LMatch RdrName] -> Bool
333 has_args [] = panic "RdrHsSyn:has_args"
334 has_args ((L _ (Match args _ _)) : _) = not (null args)
335 -- Don't group together FunBinds if they have
336 -- no arguments. This is necessary now that variable bindings
337 -- with no arguments are now treated as FunBinds rather
338 -- than pattern bindings (tests/rename/should_fail/rnfail002).
341 %************************************************************************
343 \subsection[PrefixToHS-utils]{Utilities for conversion}
345 %************************************************************************
349 -----------------------------------------------------------------------------
352 -- When parsing data declarations, we sometimes inadvertently parse
353 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
354 -- This function splits up the type application, adds any pending
355 -- arguments, and converts the type constructor back into a data constructor.
357 splitCon :: LHsType RdrName
358 -> P (Located RdrName, HsConDeclDetails RdrName)
359 -- This gets given a "type" that should look like
361 -- or C { x::Int, y::Bool }
362 -- and returns the pieces
366 split (L _ (HsAppTy t u)) ts = split t (u : ts)
367 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
368 return (data_con, mk_rest ts)
369 split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
371 mk_rest [L _ (HsRecTy flds)] = RecCon flds
372 mk_rest ts = PrefixCon ts
374 mkDeprecatedGadtRecordDecl :: SrcSpan
376 -> [ConDeclField RdrName]
378 -> P (LConDecl RdrName)
379 -- This one uses the deprecated syntax
380 -- C { x,y ::Int } :: T a b
381 -- We give it a RecCon details right away
382 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
383 = do { data_con <- tyConToDataCon con_loc con
384 ; return (L loc (ConDecl { con_old_rec = True
385 , con_name = data_con
386 , con_explicit = Implicit
389 , con_details = RecCon flds
390 , con_res = ResTyGADT res_ty
391 , con_doc = Nothing })) }
393 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
394 -> LHsContext RdrName -> HsConDeclDetails RdrName
397 mkSimpleConDecl name qvars cxt details
398 = ConDecl { con_old_rec = False
400 , con_explicit = Explicit
403 , con_details = details
405 , con_doc = Nothing }
407 mkGadtDecl :: [Located RdrName]
408 -> LHsType RdrName -- Always a HsForAllTy
410 -- We allow C,D :: ty
411 -- and expand it as if it had been
413 -- (Just like type signatures in general.)
414 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
415 = [mk_gadt_con name | name <- names]
417 (details, res_ty) -- See Note [Sorting out the result type]
419 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
420 _other -> (PrefixCon [], tau)
423 = ConDecl { con_old_rec = False
428 , con_details = details
429 , con_res = ResTyGADT res_ty
430 , con_doc = Nothing }
431 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
433 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
434 tyConToDataCon loc tc
435 | isTcOcc (rdrNameOcc tc)
436 = return (L loc (setRdrNameSpace tc srcDataName))
438 = parseErrorSDoc loc (msg $$ extra)
440 msg = text "Not a data constructor:" <+> quotes (ppr tc)
441 extra | tc == forall_tv_RDR
442 = text "Perhaps you intended to use -XExistentialQuantification"
446 Note [Sorting out the result type]
447 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
448 In a GADT declaration which is not a record, we put the whole constr
449 type into the ResTyGADT for now; the renamer will unravel it once it
450 has sorted out operator fixities. Consider for example
451 C :: a :*: b -> a :*: b -> a :+: b
452 Initially this type will parse as
453 a :*: (b -> (a :*: (b -> (a :+: b))))
455 so it's hard to split up the arguments until we've done the precedence
456 resolution (in the renamer) On the other hand, for a record
457 { x,y :: Int } -> a :*: b
458 there is no doubt. AND we need to sort records out so that
459 we can bring x,y into scope. So:
460 * For PrefixCon we keep all the args in the ResTyGADT
461 * For RecCon we do not
464 ----------------------------------------------------------------------------
465 -- Various Syntactic Checks
467 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
468 checkInstType (L l t)
470 HsForAllTy exp tvs ctxt ty -> do
471 dict_ty <- checkDictTy ty
472 return (L l (HsForAllTy exp tvs ctxt dict_ty))
474 HsParTy ty -> checkInstType ty
476 ty -> do dict_ty <- checkDictTy (L l ty)
477 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
479 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
480 checkDictTy (L spn ty) = check ty []
482 check (HsTyVar tc) args | isRdrTc tc = done tc args
483 check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
484 check (HsAppTy l r) args = check (unLoc l) (r:args)
485 check (HsParTy t) args = check (unLoc t) args
486 check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty)
488 done tc args = return (L spn (HsPredTy (HsClassP tc args)))
490 checkTParams :: Bool -- Type/data family
492 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
493 -- checkTParams checks the type parameters of a data/newtype declaration
494 -- There are two cases:
496 -- a) Vanilla data/newtype decl. In that case
497 -- - the type parameters should all be type variables
498 -- - they may have a kind annotation
500 -- b) Family data/newtype decl. In that case
501 -- - The type parameters may be arbitrary types
502 -- - We find the type-varaible binders by find the
503 -- free type vars of those types
504 -- - We make them all kind-sig-free binders (UserTyVar)
505 -- If there are kind sigs in the type parameters, they
506 -- will fix the binder's kind when we kind-check the
508 checkTParams is_family tparams
509 | not is_family -- Vanilla case (a)
510 = do { tyvars <- checkTyVars tparams
511 ; return (tyvars, Nothing) }
512 | otherwise -- Family case (b)
513 = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
514 ; return (tyvars, Just tparams) }
516 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
517 -- Check whether the given list of type parameters are all type variables
518 -- (possibly with a kind signature). If the second argument is `False',
519 -- only type variables are allowed and we raise an error on encountering a
520 -- non-variable; otherwise, we allow non-variable arguments and return the
521 -- entire list of parameters.
522 checkTyVars tparms = mapM chk tparms
524 -- Check that the name space is correct!
525 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
526 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
527 chk (L l (HsTyVar tv))
528 | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
530 parseErrorSDoc l (text "Type found:" <+> ppr t
531 $$ text "where type variable expected, in:" <+>
532 sep (map (pprParendHsType . unLoc) tparms))
534 checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
535 checkDatatypeContext Nothing = return ()
536 checkDatatypeContext (Just (L loc c))
537 = do allowed <- extension datatypeContextsEnabled
540 (text "Illegal datatype context (use -XDatatypeContexts):" <+>
543 checkTyClHdr :: LHsType RdrName
544 -> P (Located RdrName, -- the head symbol (type or class name)
545 [LHsType RdrName]) -- parameters of head symbol
546 -- Well-formedness check and decomposition of type and class heads.
547 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
548 -- Int :*: Bool into (:*:, [Int, Bool])
549 -- returning the pieces
553 goL (L l ty) acc = go l ty acc
555 go l (HsTyVar tc) acc
556 | isRdrTc tc = return (L l tc, acc)
558 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
559 | isRdrTc tc = return (ltc, t1:t2:acc)
560 go _ (HsParTy ty) acc = goL ty acc
561 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
562 go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
564 -- Check that associated type declarations of a class are all kind signatures.
566 checkKindSigs :: [LTyClDecl RdrName] -> P ()
567 checkKindSigs = mapM_ check
570 | isFamilyDecl tydecl
571 || isSynDecl tydecl = return ()
573 parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl)
575 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
579 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
580 = do ctx <- mapM checkPred ts
583 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
586 check (HsTyVar t) -- Empty context shows up as a unit type ()
587 | t == getRdrName unitTyCon = return (L l [])
590 = do p <- checkPred (L l t)
594 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
595 -- Watch out.. in ...deriving( Show )... we use checkPred on
596 -- the list of partially applied predicates in the deriving,
597 -- so there can be zero args.
598 checkPred (L spn (HsPredTy (HsIParam n ty)))
599 = return (L spn (HsIParam n ty))
603 checkl (L l ty) args = check l ty args
605 check _loc (HsPredTy pred@(HsEqualP _ _))
607 = return $ L spn pred
608 check _loc (HsTyVar t) args | not (isRdrTyVar t)
609 = return (L spn (HsClassP t args))
610 check _loc (HsAppTy l r) args = checkl l (r:args)
611 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
612 check _loc (HsParTy t) args = checkl t args
613 check loc _ _ = parseErrorSDoc loc
614 (text "malformed class assertion:" <+> ppr ty)
616 ---------------------------------------------------------------------------
617 -- Checking statements in a do-expression
618 -- We parse do { e1 ; e2 ; }
619 -- as [ExprStmt e1, ExprStmt e2]
620 -- checkDo (a) checks that the last thing is an ExprStmt
621 -- (b) returns it separately
622 -- same comments apply for mdo as well
624 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
626 checkDo = checkDoMDo "a " "'do'"
627 checkMDo = checkDoMDo "an " "'mdo'"
629 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
630 checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct"))
631 checkDoMDo pre nm _ ss = do
634 check [] = panic "RdrHsSyn:checkDoMDo"
635 check [L _ (ExprStmt e _ _ _)] = return ([], e)
636 check [L l e] = parseErrorSDoc l
637 (text ("The last statement in " ++ pre ++ nm ++
638 " construct must be an expression:")
644 -- -------------------------------------------------------------------------
645 -- Checking Patterns.
647 -- We parse patterns as expressions and check for valid patterns below,
648 -- converting the expression into a pattern at the same time.
650 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
651 checkPattern e = checkLPat e
653 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
654 checkPatterns es = mapM checkPattern es
656 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
657 checkLPat e@(L l _) = checkPat l e []
659 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
660 checkPat loc (L l (HsVar c)) args
661 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
662 checkPat loc e args -- OK to let this happen even if bang-patterns
663 -- are not enabled, because there is no valid
664 -- non-bang-pattern parse of (C ! e)
665 | Just (e', args') <- splitBang e
666 = do { args'' <- checkPatterns args'
667 ; checkPat loc e' (args'' ++ args) }
668 checkPat loc (L _ (HsApp f x)) args
669 = do { x <- checkLPat x; checkPat loc f (x:args) }
670 checkPat loc (L _ e) []
671 = do { pState <- getPState
672 ; p <- checkAPat (dflags pState) loc e
675 = patFail loc (unLoc e)
677 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
678 checkAPat dynflags loc e0 = case e0 of
679 EWildPat -> return (WildPat placeHolderType)
680 HsVar x -> return (VarPat x)
681 HsLit l -> return (LitPat l)
683 -- Overloaded numeric patterns (e.g. f 0 x = x)
684 -- Negation is recorded separately, so that the literal is zero or +ve
685 -- NB. Negative *primitive* literals are already handled by the lexer
686 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
687 NegApp (L _ (HsOverLit pos_lit)) _
688 -> return (mkNPat pos_lit (Just noSyntaxExpr))
690 SectionR (L _ (HsVar bang)) e -- (! x)
692 -> do { bang_on <- extension bangPatEnabled
693 ; if bang_on then checkLPat e >>= (return . BangPat)
694 else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) }
696 ELazyPat e -> checkLPat e >>= (return . LazyPat)
697 EAsPat n e -> checkLPat e >>= (return . AsPat n)
698 -- view pattern is well-formed if the pattern is
699 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
700 ExprWithTySig e t -> do e <- checkLPat e
701 -- Pattern signatures are parsed as sigtypes,
702 -- but they aren't explicit forall points. Hence
703 -- we have to remove the implicit forall here.
705 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
707 return (SigPatIn e t')
710 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
711 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
712 | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
713 -> return (mkNPlusKPat (L nloc n) lit)
715 OpApp l op _fix r -> do l <- checkLPat l
718 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
719 -> return (ConPatIn (L cl c) (InfixCon l r))
722 HsPar e -> checkLPat e >>= (return . ParPat)
723 ExplicitList _ es -> do ps <- mapM checkLPat es
724 return (ListPat ps placeHolderType)
725 ExplicitPArr _ es -> do ps <- mapM checkLPat es
726 return (PArrPat ps placeHolderType)
729 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
730 return (TuplePat ps b placeHolderType)
731 | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
733 RecordCon c _ (HsRecFields fs dd)
734 -> do fs <- mapM checkPatField fs
735 return (ConPatIn c (RecCon (HsRecFields fs dd)))
736 HsQuasiQuoteE q -> return (QuasiQuotePat q)
738 HsType ty -> return (TypePat ty)
741 placeHolderPunRhs :: LHsExpr RdrName
742 -- The RHS of a punned record field will be filled in by the renamer
743 -- It's better not to make it an error, in case we want to print it when debugging
744 placeHolderPunRhs = noLoc (HsVar pun_RDR)
746 plus_RDR, bang_RDR, pun_RDR :: RdrName
747 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
748 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
749 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
751 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
752 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
753 ; return (fld { hsRecFieldArg = p }) }
755 patFail :: SrcSpan -> HsExpr RdrName -> P a
756 patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e)
759 ---------------------------------------------------------------------------
760 -- Check Equation Syntax
762 checkValDef :: LHsExpr RdrName
763 -> Maybe (LHsType RdrName)
764 -> Located (GRHSs RdrName)
765 -> P (HsBind RdrName)
767 checkValDef lhs (Just sig) grhss
768 -- x :: ty = rhs parses as a *pattern* binding
769 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
771 checkValDef lhs opt_sig grhss
772 = do { mb_fun <- isFunLhs lhs
774 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
775 fun is_infix pats opt_sig grhss
776 Nothing -> checkPatBind lhs grhss }
778 checkFunBind :: SrcSpan
782 -> Maybe (LHsType RdrName)
783 -> Located (GRHSs RdrName)
784 -> P (HsBind RdrName)
785 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
786 = do ps <- checkPatterns pats
787 let match_span = combineSrcSpans lhs_loc rhs_span
788 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
789 -- The span of the match covers the entire equation.
790 -- That isn't quite right, but it'll do for now.
792 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
793 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
794 makeFunBind fn is_infix ms
795 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
796 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
798 checkPatBind :: LHsExpr RdrName
799 -> Located (GRHSs RdrName)
800 -> P (HsBind RdrName)
801 checkPatBind lhs (L _ grhss)
802 = do { lhs <- checkPattern lhs
803 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
809 checkValSig (L l (HsVar v)) ty
810 | isUnqual v && not (isDataOcc (rdrNameOcc v))
811 = return (TypeSig (L l v) ty)
812 checkValSig lhs@(L l _) ty
813 = parseErrorSDoc l ((text "Invalid type signature:" <+>
814 ppr lhs <+> text "::" <+> ppr ty)
817 hint = if looks_like_foreign lhs
818 then "Perhaps you meant to use -XForeignFunctionInterface?"
819 else "Should be of form <variable> :: <type>"
820 -- A common error is to forget the ForeignFunctionInterface flag
821 -- so check for that, and suggest. cf Trac #3805
822 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
823 looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR
824 looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
825 looks_like_foreign _ = False
827 foreign_RDR = mkUnqual varName (fsLit "foreign")
829 checkDoAndIfThenElse :: LHsExpr RdrName
835 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
836 | semiThen || semiElse
837 = do pState <- getPState
838 unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do
839 parseErrorSDoc (combineLocs guardExpr elseExpr)
840 (text "Unexpected semi-colons in conditional:"
842 $$ text "Perhaps you meant to use -XDoAndIfThenElse?")
843 | otherwise = return ()
844 where pprOptSemi True = semi
845 pprOptSemi False = empty
846 expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
847 text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
848 text "else" <+> ppr elseExpr
853 -- The parser left-associates, so there should
854 -- not be any OpApps inside the e's
855 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
856 -- Splits (f ! g a b) into (f, [(! g), a, b])
857 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
858 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
860 (arg1,argns) = split_bang r_arg []
861 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
862 split_bang e es = (e,es)
863 splitBang _ = Nothing
865 isFunLhs :: LHsExpr RdrName
866 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
867 -- A variable binding is parsed as a FunBind.
868 -- Just (fun, is_infix, arg_pats) if e is a function LHS
870 -- The whole LHS is parsed as a single expression.
871 -- Any infix operators on the LHS will parse left-associatively
873 -- will parse (rather strangely) as
875 -- It's up to isFunLhs to sort out the mess
881 go (L loc (HsVar f)) es
882 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
883 go (L _ (HsApp f e)) es = go f (e:es)
884 go (L _ (HsPar e)) es@(_:_) = go e es
886 -- For infix function defns, there should be only one infix *function*
887 -- (though there may be infix *datacons* involved too). So we don't
888 -- need fixity info to figure out which function is being defined.
889 -- a `K1` b `op` c `K2` d
891 -- (a `K1` b) `op` (c `K2` d)
892 -- The renamer checks later that the precedences would yield such a parse.
894 -- There is a complication to deal with bang patterns.
896 -- ToDo: what about this?
897 -- x + 1 `op` y = ...
899 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
900 | Just (e',es') <- splitBang e
901 = do { bang_on <- extension bangPatEnabled
902 ; if bang_on then go e' (es' ++ es)
903 else return (Just (L loc' op, True, (l:r:es))) }
904 -- No bangs; behave just like the next case
905 | not (isRdrDataCon op) -- We have found the function!
906 = return (Just (L loc' op, True, (l:r:es)))
907 | otherwise -- Infix data con; keep going
908 = do { mb_l <- go l es
910 Just (op', True, j : k : es')
911 -> return (Just (op', True, j : op_app : es'))
913 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
914 _ -> return Nothing }
915 go _ _ = return Nothing
918 ---------------------------------------------------------------------------
919 -- Check for monad comprehensions
921 -- If the flag MonadComprehensions is set, return a `MonadComp' context,
922 -- otherwise use the usual `ListComp' context
924 checkMonadComp :: P (HsStmtContext Name)
927 return $ if xopt Opt_MonadComprehensions (dflags pState)
931 ---------------------------------------------------------------------------
932 -- Miscellaneous utilities
934 checkPrecP :: Located Int -> P Int
936 | 0 <= i && i <= maxPrecedence = return i
938 = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
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 = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp)
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 mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
957 -- The Maybe is because the user can omit the activation spec (and usually does)
958 mkInlinePragma (inl, match_info) mb_act
959 = InlinePragma { inl_inline = inl
962 , inl_rule = match_info }
966 Nothing -> -- No phase specified
968 NoInline -> NeverActive
969 _other -> AlwaysActive
971 -----------------------------------------------------------------------------
972 -- utilities for foreign declarations
974 -- construct a foreign import declaration
976 mkImport :: CCallConv
978 -> (Located FastString, Located RdrName, LHsType RdrName)
979 -> P (HsDecl RdrName)
980 mkImport cconv safety (L loc entity, v, ty)
981 | cconv == PrimCallConv = do
982 let funcTarget = CFunction (StaticTarget entity Nothing)
983 importSpec = CImport PrimCallConv safety nilFS funcTarget
984 return (ForD (ForeignImport v ty importSpec))
987 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
988 Nothing -> parseErrorSDoc loc (text "Malformed entity string")
989 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
991 -- the string "foo" is ambigous: either a header or a C identifier. The
992 -- C identifier case comes first in the alternatives below, so we pick
994 parseCImport :: CCallConv -> Safety -> FastString -> String
995 -> Maybe ForeignImport
996 parseCImport cconv safety nm str =
997 listToMaybe $ map fst $ filter (null.snd) $
1003 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
1004 string "wrapper" >> return (mk nilFS CWrapper),
1005 optional (string "static" >> skipSpaces) >>
1006 (mk nilFS <$> cimp nm) +++
1007 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
1012 mk = CImport cconv safety
1014 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
1015 -- pretty much any char (depending on the platform),
1016 -- so just accept any non-space character
1017 id_char c = isAlphaNum c || c == '_'
1019 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1020 +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
1023 (do c <- satisfy (\c -> isAlpha c || c == '_')
1024 cs <- many (satisfy id_char)
1025 return (mkFastString (c:cs)))
1028 -- construct a foreign export declaration
1030 mkExport :: CCallConv
1031 -> (Located FastString, Located RdrName, LHsType RdrName)
1032 -> P (HsDecl RdrName)
1033 mkExport cconv (L _ entity, v, ty) = return $
1034 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1036 entity' | nullFS entity = mkExtName (unLoc v)
1037 | otherwise = entity
1039 -- Supplying the ext_name in a foreign decl is optional; if it
1040 -- isn't there, the Haskell name is assumed. Note that no transformation
1041 -- of the Haskell name is then performed, so if you foreign export (++),
1042 -- it's external name will be "++". Too bad; it's important because we don't
1043 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1045 mkExtName :: RdrName -> CLabelString
1046 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1050 -----------------------------------------------------------------------------
1054 parseError :: SrcSpan -> String -> P a
1055 parseError span s = parseErrorSDoc span (text s)
1057 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1058 parseErrorSDoc span s = failSpanMsgP span s