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 checkMonadComp, -- P (HsStmtContext RdrName)
44 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
45 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
51 import HsSyn -- Lots of it
52 import Class ( FunDep )
53 import TypeRep ( Kind )
54 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
55 isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
57 import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo,
58 InlinePragma(..), InlineSpec(..) )
60 import TysWiredIn ( unitTyCon )
62 import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
64 import PrelNames ( forall_tv_RDR )
67 import OrdList ( OrdList, fromOL )
68 import Bag ( Bag, emptyBag, consBag, foldrBag )
73 import Control.Applicative ((<$>))
75 import Text.ParserCombinators.ReadP as ReadP
76 import Data.List ( nubBy )
79 #include "HsVersions.h"
83 %************************************************************************
85 \subsection{A few functions over HsSyn at RdrName}
87 %************************************************************************
89 extractHsTyRdrNames finds the free variables of a HsType
90 It's used when making the for-alls explicit.
93 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
94 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
96 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
97 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
99 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
100 -- This one takes the context and tau-part of a
101 -- sigma type and returns their free type variables
102 extractHsRhoRdrTyVars ctxt ty
103 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
105 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
106 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
108 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
109 extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
110 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
111 extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
113 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
114 extract_ltys tys acc = foldr extract_lty acc tys
116 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
117 extract_lty (L loc ty) acc
119 HsTyVar tv -> extract_tv loc tv acc
120 HsBangTy _ ty -> extract_lty ty acc
121 HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
122 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
123 HsListTy ty -> extract_lty ty acc
124 HsPArrTy ty -> extract_lty ty acc
125 HsTupleTy _ tys -> extract_ltys tys acc
126 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
127 HsPredTy p -> extract_pred p acc
128 HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
129 HsParTy ty -> extract_lty ty acc
130 HsCoreTy {} -> acc -- The type is closed
131 HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
132 HsSpliceTy {} -> acc -- Type splices mention no type variables
133 HsKindSig ty _ -> extract_lty ty acc
134 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
135 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
136 extract_lctxt cx (extract_lty ty []))
138 locals = hsLTyVarNames tvs
139 HsDocTy ty _ -> extract_lty ty acc
141 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
142 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
145 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
146 -- Get the type variables out of the type patterns in a bunch of
147 -- possibly-generic bindings in a class declaration
148 extractGenericPatTyVars binds
149 = nubBy eqLocated (foldrBag get [] binds)
151 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
158 %************************************************************************
160 \subsection{Construction functions for Rdr stuff}
162 %************************************************************************
164 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
165 by deriving them from the name of the class. We fill in the names for the
166 tycon and datacon corresponding to the class, by deriving them from the
167 name of the class itself. This saves recording the names in the interface
168 file (which would be equally good).
170 Similarly for mkConDecl, mkClassOpSig and default-method names.
172 *** See "THE NAMING STORY" in HsDecls ****
175 mkClassDecl :: SrcSpan
176 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
177 -> Located [Located (FunDep RdrName)]
178 -> Located (OrdList (LHsDecl RdrName))
179 -> P (LTyClDecl RdrName)
181 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
182 = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
183 ; let cxt = fromMaybe (noLoc []) mcxt
184 ; (cls, tparams) <- checkTyClHdr tycl_hdr
185 ; tyvars <- checkTyVars tparams -- Only type vars allowed
187 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
188 tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
189 tcdATs = ats, tcdDocs = docs })) }
193 -> Bool -- True <=> data family instance
194 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
196 -> [LConDecl RdrName]
197 -> Maybe [LHsType RdrName]
198 -> P (LTyClDecl RdrName)
199 mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
200 = do { (tc, tparams) <- checkTyClHdr tycl_hdr
202 ; checkDatatypeContext mcxt
203 ; let cxt = fromMaybe (noLoc []) mcxt
204 ; (tyvars, typats) <- checkTParams is_family tparams
205 ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
206 tcdTyVars = tyvars, tcdTyPats = typats,
208 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
210 mkTySynonym :: SrcSpan
211 -> Bool -- True <=> type family instances
212 -> LHsType RdrName -- LHS
213 -> LHsType RdrName -- RHS
214 -> P (LTyClDecl RdrName)
215 mkTySynonym loc is_family lhs rhs
216 = do { (tc, tparams) <- checkTyClHdr lhs
217 ; (tyvars, typats) <- checkTParams is_family tparams
218 ; return (L loc (TySynonym tc tyvars typats rhs)) }
220 mkTyFamily :: SrcSpan
222 -> LHsType RdrName -- LHS
223 -> Maybe Kind -- Optional kind signature
224 -> P (LTyClDecl RdrName)
225 mkTyFamily loc flavour lhs ksig
226 = do { (tc, tparams) <- checkTyClHdr lhs
227 ; tyvars <- checkTyVars tparams
228 ; return (L loc (TyFamily flavour tc tyvars ksig)) }
230 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
232 -- [pads| ... ] then return a QuasiQuoteD
233 -- $(e) then return a SpliceD
234 -- but if she wrote, say,
235 -- f x then behave as if she'd written $(f x)
237 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq
238 mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit)
239 mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit)
242 %************************************************************************
244 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
246 %************************************************************************
248 Function definitions are restructured here. Each is assumed to be recursive
249 initially, and non recursive definitions are discovered by the dependency
254 -- | Groups together bindings for a single function
255 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
256 cvTopDecls decls = go (fromOL decls)
258 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
260 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
261 where (L l' b', ds') = getMonoBind (L l b) ds
262 go (d : ds) = d : go ds
264 -- Declaration list may only contain value bindings and signatures.
265 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
267 = case cvBindsAndSigs binding of
268 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
271 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
272 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
273 -- Input decls contain just value bindings and signatures
274 -- and in case of class or instance declarations also
275 -- associated type declarations. They might also contain Haddock comments.
276 cvBindsAndSigs fb = go (fromOL fb)
278 go [] = (emptyBag, [], [], [])
279 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
280 where (bs, ss, ts, docs) = go ds
281 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
282 where (b', ds') = getMonoBind (L l b) ds
283 (bs, ss, ts, docs) = go ds'
284 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
285 where (bs, ss, ts, docs) = go ds
286 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
287 where (bs, ss, ts, docs) = go ds
288 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
290 -----------------------------------------------------------------------------
291 -- Group function bindings into equation groups
293 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
294 -> (LHsBind RdrName, [LHsDecl RdrName])
295 -- Suppose (b',ds') = getMonoBind b ds
296 -- ds is a list of parsed bindings
297 -- b is a MonoBinds that has just been read off the front
299 -- Then b' is the result of grouping more equations from ds that
300 -- belong with b into a single MonoBinds, and ds' is the depleted
301 -- list of parsed bindings.
303 -- All Haddock comments between equations inside the group are
306 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
308 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
309 fun_matches = MatchGroup mtchs1 _ })) binds
311 = go is_infix1 mtchs1 loc1 binds []
313 go is_infix mtchs loc
314 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
315 fun_matches = MatchGroup mtchs2 _ })) : binds) _
316 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
317 (combineSrcSpans loc loc2) binds []
318 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
319 = let doc_decls' = doc_decl : doc_decls
320 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
321 go is_infix mtchs loc binds doc_decls
322 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
323 -- Reverse the final matches, to get it back in the right order
324 -- Do the same thing with the trailing doc comments
326 getMonoBind bind binds = (bind, binds)
328 has_args :: [LMatch RdrName] -> Bool
329 has_args [] = panic "RdrHsSyn:has_args"
330 has_args ((L _ (Match args _ _)) : _) = not (null args)
331 -- Don't group together FunBinds if they have
332 -- no arguments. This is necessary now that variable bindings
333 -- with no arguments are now treated as FunBinds rather
334 -- than pattern bindings (tests/rename/should_fail/rnfail002).
337 %************************************************************************
339 \subsection[PrefixToHS-utils]{Utilities for conversion}
341 %************************************************************************
345 -----------------------------------------------------------------------------
348 -- When parsing data declarations, we sometimes inadvertently parse
349 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
350 -- This function splits up the type application, adds any pending
351 -- arguments, and converts the type constructor back into a data constructor.
353 splitCon :: LHsType RdrName
354 -> P (Located RdrName, HsConDeclDetails RdrName)
355 -- This gets given a "type" that should look like
357 -- or C { x::Int, y::Bool }
358 -- and returns the pieces
362 split (L _ (HsAppTy t u)) ts = split t (u : ts)
363 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
364 return (data_con, mk_rest ts)
365 split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
367 mk_rest [L _ (HsRecTy flds)] = RecCon flds
368 mk_rest ts = PrefixCon ts
370 mkDeprecatedGadtRecordDecl :: SrcSpan
372 -> [ConDeclField RdrName]
374 -> P (LConDecl RdrName)
375 -- This one uses the deprecated syntax
376 -- C { x,y ::Int } :: T a b
377 -- We give it a RecCon details right away
378 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
379 = do { data_con <- tyConToDataCon con_loc con
380 ; return (L loc (ConDecl { con_old_rec = True
381 , con_name = data_con
382 , con_explicit = Implicit
385 , con_details = RecCon flds
386 , con_res = ResTyGADT res_ty
387 , con_doc = Nothing })) }
389 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
390 -> LHsContext RdrName -> HsConDeclDetails RdrName
393 mkSimpleConDecl name qvars cxt details
394 = ConDecl { con_old_rec = False
396 , con_explicit = Explicit
399 , con_details = details
401 , con_doc = Nothing }
403 mkGadtDecl :: [Located RdrName]
404 -> LHsType RdrName -- Always a HsForAllTy
406 -- We allow C,D :: ty
407 -- and expand it as if it had been
409 -- (Just like type signatures in general.)
410 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
411 = [mk_gadt_con name | name <- names]
413 (details, res_ty) -- See Note [Sorting out the result type]
415 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
416 _other -> (PrefixCon [], tau)
419 = ConDecl { con_old_rec = False
424 , con_details = details
425 , con_res = ResTyGADT res_ty
426 , con_doc = Nothing }
427 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
429 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
430 tyConToDataCon loc tc
431 | isTcOcc (rdrNameOcc tc)
432 = return (L loc (setRdrNameSpace tc srcDataName))
434 = parseErrorSDoc loc (msg $$ extra)
436 msg = text "Not a data constructor:" <+> quotes (ppr tc)
437 extra | tc == forall_tv_RDR
438 = text "Perhaps you intended to use -XExistentialQuantification"
442 Note [Sorting out the result type]
443 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
444 In a GADT declaration which is not a record, we put the whole constr
445 type into the ResTyGADT for now; the renamer will unravel it once it
446 has sorted out operator fixities. Consider for example
447 C :: a :*: b -> a :*: b -> a :+: b
448 Initially this type will parse as
449 a :*: (b -> (a :*: (b -> (a :+: b))))
451 so it's hard to split up the arguments until we've done the precedence
452 resolution (in the renamer) On the other hand, for a record
453 { x,y :: Int } -> a :*: b
454 there is no doubt. AND we need to sort records out so that
455 we can bring x,y into scope. So:
456 * For PrefixCon we keep all the args in the ResTyGADT
457 * For RecCon we do not
460 ----------------------------------------------------------------------------
461 -- Various Syntactic Checks
463 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
464 checkInstType (L l t)
466 HsForAllTy exp tvs ctxt ty -> do
467 dict_ty <- checkDictTy ty
468 return (L l (HsForAllTy exp tvs ctxt dict_ty))
470 HsParTy ty -> checkInstType ty
472 ty -> do dict_ty <- checkDictTy (L l ty)
473 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
475 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
476 checkDictTy (L spn ty) = check ty []
478 check (HsTyVar tc) args | isRdrTc tc = done tc args
479 check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
480 check (HsAppTy l r) args = check (unLoc l) (r:args)
481 check (HsParTy t) args = check (unLoc t) args
482 check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty)
484 done tc args = return (L spn (HsPredTy (HsClassP tc args)))
486 checkTParams :: Bool -- Type/data family
488 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
489 -- checkTParams checks the type parameters of a data/newtype declaration
490 -- There are two cases:
492 -- a) Vanilla data/newtype decl. In that case
493 -- - the type parameters should all be type variables
494 -- - they may have a kind annotation
496 -- b) Family data/newtype decl. In that case
497 -- - The type parameters may be arbitrary types
498 -- - We find the type-varaible binders by find the
499 -- free type vars of those types
500 -- - We make them all kind-sig-free binders (UserTyVar)
501 -- If there are kind sigs in the type parameters, they
502 -- will fix the binder's kind when we kind-check the
504 checkTParams is_family tparams
505 | not is_family -- Vanilla case (a)
506 = do { tyvars <- checkTyVars tparams
507 ; return (tyvars, Nothing) }
508 | otherwise -- Family case (b)
509 = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
510 ; return (tyvars, Just tparams) }
512 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
513 -- Check whether the given list of type parameters are all type variables
514 -- (possibly with a kind signature). If the second argument is `False',
515 -- only type variables are allowed and we raise an error on encountering a
516 -- non-variable; otherwise, we allow non-variable arguments and return the
517 -- entire list of parameters.
518 checkTyVars tparms = mapM chk tparms
520 -- Check that the name space is correct!
521 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
522 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
523 chk (L l (HsTyVar tv))
524 | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
526 parseErrorSDoc l (text "Type found:" <+> ppr t
527 $$ text "where type variable expected, in:" <+>
528 sep (map (pprParendHsType . unLoc) tparms))
530 checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
531 checkDatatypeContext Nothing = return ()
532 checkDatatypeContext (Just (L loc c))
533 = do allowed <- extension datatypeContextsEnabled
536 (text "Illegal datatype context (use -XDatatypeContexts):" <+>
539 checkTyClHdr :: LHsType RdrName
540 -> P (Located RdrName, -- the head symbol (type or class name)
541 [LHsType RdrName]) -- parameters of head symbol
542 -- Well-formedness check and decomposition of type and class heads.
543 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
544 -- Int :*: Bool into (:*:, [Int, Bool])
545 -- returning the pieces
549 goL (L l ty) acc = go l ty acc
551 go l (HsTyVar tc) acc
552 | isRdrTc tc = return (L l tc, acc)
554 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
555 | isRdrTc tc = return (ltc, t1:t2:acc)
556 go _ (HsParTy ty) acc = goL ty acc
557 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
558 go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
560 -- Check that associated type declarations of a class are all kind signatures.
562 checkKindSigs :: [LTyClDecl RdrName] -> P ()
563 checkKindSigs = mapM_ check
566 | isFamilyDecl tydecl
567 || isSynDecl tydecl = return ()
569 parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl)
571 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
575 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
576 = do ctx <- mapM checkPred ts
579 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
582 check (HsTyVar t) -- Empty context shows up as a unit type ()
583 | t == getRdrName unitTyCon = return (L l [])
586 = do p <- checkPred (L l t)
590 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
591 -- Watch out.. in ...deriving( Show )... we use checkPred on
592 -- the list of partially applied predicates in the deriving,
593 -- so there can be zero args.
594 checkPred (L spn (HsPredTy (HsIParam n ty)))
595 = return (L spn (HsIParam n ty))
599 checkl (L l ty) args = check l ty args
601 check _loc (HsPredTy pred@(HsEqualP _ _))
603 = return $ L spn pred
604 check _loc (HsTyVar t) args | not (isRdrTyVar t)
605 = return (L spn (HsClassP t args))
606 check _loc (HsAppTy l r) args = checkl l (r:args)
607 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
608 check _loc (HsParTy t) args = checkl t args
609 check loc _ _ = parseErrorSDoc loc
610 (text "malformed class assertion:" <+> ppr ty)
612 -- -------------------------------------------------------------------------
613 -- Checking Patterns.
615 -- We parse patterns as expressions and check for valid patterns below,
616 -- converting the expression into a pattern at the same time.
618 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
619 checkPattern e = checkLPat e
621 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
622 checkPatterns es = mapM checkPattern es
624 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
625 checkLPat e@(L l _) = checkPat l e []
627 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
628 checkPat loc (L l (HsVar c)) args
629 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
630 checkPat loc e args -- OK to let this happen even if bang-patterns
631 -- are not enabled, because there is no valid
632 -- non-bang-pattern parse of (C ! e)
633 | Just (e', args') <- splitBang e
634 = do { args'' <- checkPatterns args'
635 ; checkPat loc e' (args'' ++ args) }
636 checkPat loc (L _ (HsApp f x)) args
637 = do { x <- checkLPat x; checkPat loc f (x:args) }
638 checkPat loc (L _ e) []
639 = do { pState <- getPState
640 ; p <- checkAPat (dflags pState) loc e
643 = patFail loc (unLoc e)
645 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
646 checkAPat dynflags loc e0 = case e0 of
647 EWildPat -> return (WildPat placeHolderType)
648 HsVar x -> return (VarPat x)
649 HsLit l -> return (LitPat l)
651 -- Overloaded numeric patterns (e.g. f 0 x = x)
652 -- Negation is recorded separately, so that the literal is zero or +ve
653 -- NB. Negative *primitive* literals are already handled by the lexer
654 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
655 NegApp (L _ (HsOverLit pos_lit)) _
656 -> return (mkNPat pos_lit (Just noSyntaxExpr))
658 SectionR (L _ (HsVar bang)) e -- (! x)
660 -> do { bang_on <- extension bangPatEnabled
661 ; if bang_on then checkLPat e >>= (return . BangPat)
662 else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) }
664 ELazyPat e -> checkLPat e >>= (return . LazyPat)
665 EAsPat n e -> checkLPat e >>= (return . AsPat n)
666 -- view pattern is well-formed if the pattern is
667 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
668 ExprWithTySig e t -> do e <- checkLPat e
669 -- Pattern signatures are parsed as sigtypes,
670 -- but they aren't explicit forall points. Hence
671 -- we have to remove the implicit forall here.
673 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
675 return (SigPatIn e t')
678 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
679 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
680 | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
681 -> return (mkNPlusKPat (L nloc n) lit)
683 OpApp l op _fix r -> do l <- checkLPat l
686 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
687 -> return (ConPatIn (L cl c) (InfixCon l r))
690 HsPar e -> checkLPat e >>= (return . ParPat)
691 ExplicitList _ es -> do ps <- mapM checkLPat es
692 return (ListPat ps placeHolderType)
693 ExplicitPArr _ es -> do ps <- mapM checkLPat es
694 return (PArrPat ps placeHolderType)
697 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
698 return (TuplePat ps b placeHolderType)
699 | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
701 RecordCon c _ (HsRecFields fs dd)
702 -> do fs <- mapM checkPatField fs
703 return (ConPatIn c (RecCon (HsRecFields fs dd)))
704 HsQuasiQuoteE q -> return (QuasiQuotePat q)
707 placeHolderPunRhs :: LHsExpr RdrName
708 -- The RHS of a punned record field will be filled in by the renamer
709 -- It's better not to make it an error, in case we want to print it when debugging
710 placeHolderPunRhs = noLoc (HsVar pun_RDR)
712 plus_RDR, bang_RDR, pun_RDR :: RdrName
713 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
714 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
715 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
717 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
718 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
719 ; return (fld { hsRecFieldArg = p }) }
721 patFail :: SrcSpan -> HsExpr RdrName -> P a
722 patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e)
725 ---------------------------------------------------------------------------
726 -- Check Equation Syntax
728 checkValDef :: LHsExpr RdrName
729 -> Maybe (LHsType RdrName)
730 -> Located (GRHSs RdrName)
731 -> P (HsBind RdrName)
733 checkValDef lhs (Just sig) grhss
734 -- x :: ty = rhs parses as a *pattern* binding
735 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
737 checkValDef lhs opt_sig grhss
738 = do { mb_fun <- isFunLhs lhs
740 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
741 fun is_infix pats opt_sig grhss
742 Nothing -> checkPatBind lhs grhss }
744 checkFunBind :: SrcSpan
748 -> Maybe (LHsType RdrName)
749 -> Located (GRHSs RdrName)
750 -> P (HsBind RdrName)
751 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
752 = do ps <- checkPatterns pats
753 let match_span = combineSrcSpans lhs_loc rhs_span
754 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
755 -- The span of the match covers the entire equation.
756 -- That isn't quite right, but it'll do for now.
758 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
759 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
760 makeFunBind fn is_infix ms
761 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
762 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
764 checkPatBind :: LHsExpr RdrName
765 -> Located (GRHSs RdrName)
766 -> P (HsBind RdrName)
767 checkPatBind lhs (L _ grhss)
768 = do { lhs <- checkPattern lhs
769 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
775 checkValSig (L l (HsVar v)) ty
776 | isUnqual v && not (isDataOcc (rdrNameOcc v))
777 = return (TypeSig (L l v) ty)
778 checkValSig lhs@(L l _) ty
779 = parseErrorSDoc l ((text "Invalid type signature:" <+>
780 ppr lhs <+> text "::" <+> ppr ty)
783 hint = if foreign_RDR `looks_like` lhs
784 then "Perhaps you meant to use -XForeignFunctionInterface?"
785 else if default_RDR `looks_like` lhs
786 then "Perhaps you meant to use -XDefaultSignatures?"
787 else "Should be of form <variable> :: <type>"
788 -- A common error is to forget the ForeignFunctionInterface flag
789 -- so check for that, and suggest. cf Trac #3805
790 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
791 looks_like s (L _ (HsVar v)) = v == s
792 looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
793 looks_like _ _ = False
795 foreign_RDR = mkUnqual varName (fsLit "foreign")
796 default_RDR = mkUnqual varName (fsLit "default")
798 checkDoAndIfThenElse :: LHsExpr RdrName
804 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
805 | semiThen || semiElse
806 = do pState <- getPState
807 unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do
808 parseErrorSDoc (combineLocs guardExpr elseExpr)
809 (text "Unexpected semi-colons in conditional:"
811 $$ text "Perhaps you meant to use -XDoAndIfThenElse?")
812 | otherwise = return ()
813 where pprOptSemi True = semi
814 pprOptSemi False = empty
815 expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
816 text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
817 text "else" <+> ppr elseExpr
822 -- The parser left-associates, so there should
823 -- not be any OpApps inside the e's
824 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
825 -- Splits (f ! g a b) into (f, [(! g), a, b])
826 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
827 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
829 (arg1,argns) = split_bang r_arg []
830 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
831 split_bang e es = (e,es)
832 splitBang _ = Nothing
834 isFunLhs :: LHsExpr RdrName
835 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
836 -- A variable binding is parsed as a FunBind.
837 -- Just (fun, is_infix, arg_pats) if e is a function LHS
839 -- The whole LHS is parsed as a single expression.
840 -- Any infix operators on the LHS will parse left-associatively
842 -- will parse (rather strangely) as
844 -- It's up to isFunLhs to sort out the mess
850 go (L loc (HsVar f)) es
851 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
852 go (L _ (HsApp f e)) es = go f (e:es)
853 go (L _ (HsPar e)) es@(_:_) = go e es
855 -- For infix function defns, there should be only one infix *function*
856 -- (though there may be infix *datacons* involved too). So we don't
857 -- need fixity info to figure out which function is being defined.
858 -- a `K1` b `op` c `K2` d
860 -- (a `K1` b) `op` (c `K2` d)
861 -- The renamer checks later that the precedences would yield such a parse.
863 -- There is a complication to deal with bang patterns.
865 -- ToDo: what about this?
866 -- x + 1 `op` y = ...
868 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
869 | Just (e',es') <- splitBang e
870 = do { bang_on <- extension bangPatEnabled
871 ; if bang_on then go e' (es' ++ es)
872 else return (Just (L loc' op, True, (l:r:es))) }
873 -- No bangs; behave just like the next case
874 | not (isRdrDataCon op) -- We have found the function!
875 = return (Just (L loc' op, True, (l:r:es)))
876 | otherwise -- Infix data con; keep going
877 = do { mb_l <- go l es
879 Just (op', True, j : k : es')
880 -> return (Just (op', True, j : op_app : es'))
882 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
883 _ -> return Nothing }
884 go _ _ = return Nothing
887 ---------------------------------------------------------------------------
888 -- Check for monad comprehensions
890 -- If the flag MonadComprehensions is set, return a `MonadComp' context,
891 -- otherwise use the usual `ListComp' context
893 checkMonadComp :: P (HsStmtContext Name)
896 return $ if xopt Opt_MonadComprehensions (dflags pState)
900 ---------------------------------------------------------------------------
901 -- Miscellaneous utilities
903 checkPrecP :: Located Int -> P Int
905 | 0 <= i && i <= maxPrecedence = return i
907 = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
912 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
913 -> P (HsExpr RdrName)
915 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
916 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
917 mkRecConstrOrUpdate exp loc (fs,dd)
918 | null fs = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp)
919 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
921 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
922 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
923 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
925 mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
926 -- The Maybe is because the user can omit the activation spec (and usually does)
927 mkInlinePragma (inl, match_info) mb_act
928 = InlinePragma { inl_inline = inl
931 , inl_rule = match_info }
935 Nothing -> -- No phase specified
937 NoInline -> NeverActive
938 _other -> AlwaysActive
940 -----------------------------------------------------------------------------
941 -- utilities for foreign declarations
943 -- construct a foreign import declaration
945 mkImport :: CCallConv
947 -> (Located FastString, Located RdrName, LHsType RdrName)
948 -> P (HsDecl RdrName)
949 mkImport cconv safety (L loc entity, v, ty)
950 | cconv == PrimCallConv = do
951 let funcTarget = CFunction (StaticTarget entity Nothing)
952 importSpec = CImport PrimCallConv safety nilFS funcTarget
953 return (ForD (ForeignImport v ty importSpec))
956 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
957 Nothing -> parseErrorSDoc loc (text "Malformed entity string")
958 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
960 -- the string "foo" is ambigous: either a header or a C identifier. The
961 -- C identifier case comes first in the alternatives below, so we pick
963 parseCImport :: CCallConv -> Safety -> FastString -> String
964 -> Maybe ForeignImport
965 parseCImport cconv safety nm str =
966 listToMaybe $ map fst $ filter (null.snd) $
972 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
973 string "wrapper" >> return (mk nilFS CWrapper),
974 optional (string "static" >> skipSpaces) >>
975 (mk nilFS <$> cimp nm) +++
976 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
981 mk = CImport cconv safety
983 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
984 -- pretty much any char (depending on the platform),
985 -- so just accept any non-space character
986 id_char c = isAlphaNum c || c == '_'
988 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
989 +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
992 (do c <- satisfy (\c -> isAlpha c || c == '_')
993 cs <- many (satisfy id_char)
994 return (mkFastString (c:cs)))
997 -- construct a foreign export declaration
999 mkExport :: CCallConv
1000 -> (Located FastString, Located RdrName, LHsType RdrName)
1001 -> P (HsDecl RdrName)
1002 mkExport cconv (L _ entity, v, ty) = return $
1003 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1005 entity' | nullFS entity = mkExtName (unLoc v)
1006 | otherwise = entity
1008 -- Supplying the ext_name in a foreign decl is optional; if it
1009 -- isn't there, the Haskell name is assumed. Note that no transformation
1010 -- of the Haskell name is then performed, so if you foreign export (++),
1011 -- it's external name will be "++". Too bad; it's important because we don't
1012 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1014 mkExtName :: RdrName -> CLabelString
1015 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1019 -----------------------------------------------------------------------------
1023 parseError :: SrcSpan -> String -> P a
1024 parseError span s = parseErrorSDoc span (text s)
1026 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1027 parseErrorSDoc span s = failSpanMsgP span s