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 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
46 checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
52 import HsSyn -- Lots of it
53 import Class ( FunDep )
54 import TypeRep ( Kind )
55 import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
56 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
131 HsCoreTy {} -> acc -- The type is closed
132 HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
133 HsSpliceTy {} -> acc -- Type splices mention no type variables
134 HsKindSig ty _ -> extract_lty ty acc
135 HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
136 HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
137 extract_lctxt cx (extract_lty ty []))
139 locals = hsLTyVarNames tvs
140 HsDocTy ty _ -> extract_lty ty acc
142 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
143 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
146 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
147 -- Get the type variables out of the type patterns in a bunch of
148 -- possibly-generic bindings in a class declaration
149 extractGenericPatTyVars binds
150 = nubBy eqLocated (foldrBag get [] binds)
152 get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
155 get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
160 %************************************************************************
162 \subsection{Construction functions for Rdr stuff}
164 %************************************************************************
166 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
167 by deriving them from the name of the class. We fill in the names for the
168 tycon and datacon corresponding to the class, by deriving them from the
169 name of the class itself. This saves recording the names in the interface
170 file (which would be equally good).
172 Similarly for mkConDecl, mkClassOpSig and default-method names.
174 *** See "THE NAMING STORY" in HsDecls ****
177 mkClassDecl :: SrcSpan
178 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
179 -> Located [Located (FunDep RdrName)]
180 -> Located (OrdList (LHsDecl RdrName))
181 -> P (LTyClDecl RdrName)
183 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
184 = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
185 ; let cxt = fromMaybe (noLoc []) mcxt
186 ; (cls, tparams) <- checkTyClHdr tycl_hdr
187 ; tyvars <- checkTyVars tparams -- Only type vars allowed
189 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
190 tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
191 tcdATs = ats, tcdDocs = docs })) }
195 -> Bool -- True <=> data family instance
196 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
198 -> [LConDecl RdrName]
199 -> Maybe [LHsType RdrName]
200 -> P (LTyClDecl RdrName)
201 mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
202 = do { (tc, tparams) <- checkTyClHdr tycl_hdr
204 ; checkDatatypeContext mcxt
205 ; let cxt = fromMaybe (noLoc []) mcxt
206 ; (tyvars, typats) <- checkTParams is_family tparams
207 ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
208 tcdTyVars = tyvars, tcdTyPats = typats,
210 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
212 mkTySynonym :: SrcSpan
213 -> Bool -- True <=> type family instances
214 -> LHsType RdrName -- LHS
215 -> LHsType RdrName -- RHS
216 -> P (LTyClDecl RdrName)
217 mkTySynonym loc is_family lhs rhs
218 = do { (tc, tparams) <- checkTyClHdr lhs
219 ; (tyvars, typats) <- checkTParams is_family tparams
220 ; return (L loc (TySynonym tc tyvars typats rhs)) }
222 mkTyFamily :: SrcSpan
224 -> LHsType RdrName -- LHS
225 -> Maybe Kind -- Optional kind signature
226 -> P (LTyClDecl RdrName)
227 mkTyFamily loc flavour lhs ksig
228 = do { (tc, tparams) <- checkTyClHdr lhs
229 ; tyvars <- checkTyVars tparams
230 ; return (L loc (TyFamily flavour tc tyvars ksig)) }
232 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
234 -- [pads| ... ] then return a QuasiQuoteD
235 -- $(e) then return a SpliceD
236 -- but if she wrote, say,
237 -- f x then behave as if she'd written $(f x)
239 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq
240 mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit)
241 mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit)
244 %************************************************************************
246 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
248 %************************************************************************
250 Function definitions are restructured here. Each is assumed to be recursive
251 initially, and non recursive definitions are discovered by the dependency
256 -- | Groups together bindings for a single function
257 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
258 cvTopDecls decls = go (fromOL decls)
260 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
262 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
263 where (L l' b', ds') = getMonoBind (L l b) ds
264 go (d : ds) = d : go ds
266 -- Declaration list may only contain value bindings and signatures.
267 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
269 = case cvBindsAndSigs binding of
270 (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
273 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
274 -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
275 -- Input decls contain just value bindings and signatures
276 -- and in case of class or instance declarations also
277 -- associated type declarations. They might also contain Haddock comments.
278 cvBindsAndSigs fb = go (fromOL fb)
280 go [] = (emptyBag, [], [], [])
281 go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
282 where (bs, ss, ts, docs) = go ds
283 go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
284 where (b', ds') = getMonoBind (L l b) ds
285 (bs, ss, ts, docs) = go ds'
286 go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
287 where (bs, ss, ts, docs) = go ds
288 go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
289 where (bs, ss, ts, docs) = go ds
290 go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
292 -----------------------------------------------------------------------------
293 -- Group function bindings into equation groups
295 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
296 -> (LHsBind RdrName, [LHsDecl RdrName])
297 -- Suppose (b',ds') = getMonoBind b ds
298 -- ds is a list of parsed bindings
299 -- b is a MonoBinds that has just been read off the front
301 -- Then b' is the result of grouping more equations from ds that
302 -- belong with b into a single MonoBinds, and ds' is the depleted
303 -- list of parsed bindings.
305 -- All Haddock comments between equations inside the group are
308 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
310 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
311 fun_matches = MatchGroup mtchs1 _ })) binds
313 = go is_infix1 mtchs1 loc1 binds []
315 go is_infix mtchs loc
316 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
317 fun_matches = MatchGroup mtchs2 _ })) : binds) _
318 | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
319 (combineSrcSpans loc loc2) binds []
320 go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
321 = let doc_decls' = doc_decl : doc_decls
322 in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
323 go is_infix mtchs loc binds doc_decls
324 = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
325 -- Reverse the final matches, to get it back in the right order
326 -- Do the same thing with the trailing doc comments
328 getMonoBind bind binds = (bind, binds)
330 has_args :: [LMatch RdrName] -> Bool
331 has_args [] = panic "RdrHsSyn:has_args"
332 has_args ((L _ (Match args _ _)) : _) = not (null args)
333 -- Don't group together FunBinds if they have
334 -- no arguments. This is necessary now that variable bindings
335 -- with no arguments are now treated as FunBinds rather
336 -- than pattern bindings (tests/rename/should_fail/rnfail002).
339 %************************************************************************
341 \subsection[PrefixToHS-utils]{Utilities for conversion}
343 %************************************************************************
347 -----------------------------------------------------------------------------
350 -- When parsing data declarations, we sometimes inadvertently parse
351 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
352 -- This function splits up the type application, adds any pending
353 -- arguments, and converts the type constructor back into a data constructor.
355 splitCon :: LHsType RdrName
356 -> P (Located RdrName, HsConDeclDetails RdrName)
357 -- This gets given a "type" that should look like
359 -- or C { x::Int, y::Bool }
360 -- and returns the pieces
364 split (L _ (HsAppTy t u)) ts = split t (u : ts)
365 split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
366 return (data_con, mk_rest ts)
367 split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
369 mk_rest [L _ (HsRecTy flds)] = RecCon flds
370 mk_rest ts = PrefixCon ts
372 mkDeprecatedGadtRecordDecl :: SrcSpan
374 -> [ConDeclField RdrName]
376 -> P (LConDecl RdrName)
377 -- This one uses the deprecated syntax
378 -- C { x,y ::Int } :: T a b
379 -- We give it a RecCon details right away
380 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
381 = do { data_con <- tyConToDataCon con_loc con
382 ; return (L loc (ConDecl { con_old_rec = True
383 , con_name = data_con
384 , con_explicit = Implicit
387 , con_details = RecCon flds
388 , con_res = ResTyGADT res_ty
389 , con_doc = Nothing })) }
391 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
392 -> LHsContext RdrName -> HsConDeclDetails RdrName
395 mkSimpleConDecl name qvars cxt details
396 = ConDecl { con_old_rec = False
398 , con_explicit = Explicit
401 , con_details = details
403 , con_doc = Nothing }
405 mkGadtDecl :: [Located RdrName]
406 -> LHsType RdrName -- Always a HsForAllTy
408 -- We allow C,D :: ty
409 -- and expand it as if it had been
411 -- (Just like type signatures in general.)
412 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
413 = [mk_gadt_con name | name <- names]
415 (details, res_ty) -- See Note [Sorting out the result type]
417 L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
418 _other -> (PrefixCon [], tau)
421 = ConDecl { con_old_rec = False
426 , con_details = details
427 , con_res = ResTyGADT res_ty
428 , con_doc = Nothing }
429 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
431 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
432 tyConToDataCon loc tc
433 | isTcOcc (rdrNameOcc tc)
434 = return (L loc (setRdrNameSpace tc srcDataName))
436 = parseErrorSDoc loc (msg $$ extra)
438 msg = text "Not a data constructor:" <+> quotes (ppr tc)
439 extra | tc == forall_tv_RDR
440 = text "Perhaps you intended to use -XExistentialQuantification"
444 Note [Sorting out the result type]
445 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
446 In a GADT declaration which is not a record, we put the whole constr
447 type into the ResTyGADT for now; the renamer will unravel it once it
448 has sorted out operator fixities. Consider for example
449 C :: a :*: b -> a :*: b -> a :+: b
450 Initially this type will parse as
451 a :*: (b -> (a :*: (b -> (a :+: b))))
453 so it's hard to split up the arguments until we've done the precedence
454 resolution (in the renamer) On the other hand, for a record
455 { x,y :: Int } -> a :*: b
456 there is no doubt. AND we need to sort records out so that
457 we can bring x,y into scope. So:
458 * For PrefixCon we keep all the args in the ResTyGADT
459 * For RecCon we do not
462 ----------------------------------------------------------------------------
463 -- Various Syntactic Checks
465 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
466 checkInstType (L l t)
468 HsForAllTy exp tvs ctxt ty -> do
469 dict_ty <- checkDictTy ty
470 return (L l (HsForAllTy exp tvs ctxt dict_ty))
472 HsParTy ty -> checkInstType ty
474 ty -> do dict_ty <- checkDictTy (L l ty)
475 return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
477 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
478 checkDictTy (L spn ty) = check ty []
480 check (HsTyVar tc) args | isRdrTc tc = done tc args
481 check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
482 check (HsAppTy l r) args = check (unLoc l) (r:args)
483 check (HsParTy t) args = check (unLoc t) args
484 check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty)
486 done tc args = return (L spn (HsPredTy (HsClassP tc args)))
488 checkTParams :: Bool -- Type/data family
490 -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
491 -- checkTParams checks the type parameters of a data/newtype declaration
492 -- There are two cases:
494 -- a) Vanilla data/newtype decl. In that case
495 -- - the type parameters should all be type variables
496 -- - they may have a kind annotation
498 -- b) Family data/newtype decl. In that case
499 -- - The type parameters may be arbitrary types
500 -- - We find the type-varaible binders by find the
501 -- free type vars of those types
502 -- - We make them all kind-sig-free binders (UserTyVar)
503 -- If there are kind sigs in the type parameters, they
504 -- will fix the binder's kind when we kind-check the
506 checkTParams is_family tparams
507 | not is_family -- Vanilla case (a)
508 = do { tyvars <- checkTyVars tparams
509 ; return (tyvars, Nothing) }
510 | otherwise -- Family case (b)
511 = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
512 ; return (tyvars, Just tparams) }
514 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
515 -- Check whether the given list of type parameters are all type variables
516 -- (possibly with a kind signature). If the second argument is `False',
517 -- only type variables are allowed and we raise an error on encountering a
518 -- non-variable; otherwise, we allow non-variable arguments and return the
519 -- entire list of parameters.
520 checkTyVars tparms = mapM chk tparms
522 -- Check that the name space is correct!
523 chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
524 | isRdrTyVar tv = return (L l (KindedTyVar tv k))
525 chk (L l (HsTyVar tv))
526 | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
528 parseErrorSDoc l (text "Type found:" <+> ppr t
529 $$ text "where type variable expected, in:" <+>
530 sep (map (pprParendHsType . unLoc) tparms))
532 checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
533 checkDatatypeContext Nothing = return ()
534 checkDatatypeContext (Just (L loc c))
535 = do allowed <- extension datatypeContextsEnabled
538 (text "Illegal datatype context (use -XDatatypeContexts):" <+>
541 checkTyClHdr :: LHsType RdrName
542 -> P (Located RdrName, -- the head symbol (type or class name)
543 [LHsType RdrName]) -- parameters of head symbol
544 -- Well-formedness check and decomposition of type and class heads.
545 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
546 -- Int :*: Bool into (:*:, [Int, Bool])
547 -- returning the pieces
551 goL (L l ty) acc = go l ty acc
553 go l (HsTyVar tc) acc
554 | isRdrTc tc = return (L l tc, acc)
556 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
557 | isRdrTc tc = return (ltc, t1:t2:acc)
558 go _ (HsParTy ty) acc = goL ty acc
559 go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
560 go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
562 -- Check that associated type declarations of a class are all kind signatures.
564 checkKindSigs :: [LTyClDecl RdrName] -> P ()
565 checkKindSigs = mapM_ check
568 | isFamilyDecl tydecl
569 || isSynDecl tydecl = return ()
571 parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl)
573 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
577 check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
578 = do ctx <- mapM checkPred ts
581 check (HsParTy ty) -- to be sure HsParTy doesn't get into the way
584 check (HsTyVar t) -- Empty context shows up as a unit type ()
585 | t == getRdrName unitTyCon = return (L l [])
588 = do p <- checkPred (L l t)
592 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
593 -- Watch out.. in ...deriving( Show )... we use checkPred on
594 -- the list of partially applied predicates in the deriving,
595 -- so there can be zero args.
596 checkPred (L spn (HsPredTy (HsIParam n ty)))
597 = return (L spn (HsIParam n ty))
601 checkl (L l ty) args = check l ty args
603 check _loc (HsPredTy pred@(HsEqualP _ _))
605 = return $ L spn pred
606 check _loc (HsTyVar t) args | not (isRdrTyVar t)
607 = return (L spn (HsClassP t args))
608 check _loc (HsAppTy l r) args = checkl l (r:args)
609 check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
610 check _loc (HsParTy t) args = checkl t args
611 check loc _ _ = parseErrorSDoc loc
612 (text "malformed class assertion:" <+> ppr ty)
614 ---------------------------------------------------------------------------
615 -- Checking statements in a do-expression
616 -- We parse do { e1 ; e2 ; }
617 -- as [ExprStmt e1, ExprStmt e2]
618 -- checkDo (a) checks that the last thing is an ExprStmt
619 -- (b) returns it separately
620 -- same comments apply for mdo as well
622 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
624 checkDo = checkDoMDo "a " "'do'"
625 checkMDo = checkDoMDo "an " "'mdo'"
627 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
628 checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct"))
629 checkDoMDo pre nm _ ss = do
632 check [] = panic "RdrHsSyn:checkDoMDo"
633 check [L _ (ExprStmt e _ _)] = return ([], e)
634 check [L l e] = parseErrorSDoc l
635 (text ("The last statement in " ++ pre ++ nm ++
636 " construct must be an expression:")
642 -- -------------------------------------------------------------------------
643 -- Checking Patterns.
645 -- We parse patterns as expressions and check for valid patterns below,
646 -- converting the expression into a pattern at the same time.
648 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
649 checkPattern e = checkLPat e
651 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
652 checkPatterns es = mapM checkPattern es
654 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
655 checkLPat e@(L l _) = checkPat l e []
657 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
658 checkPat loc (L l (HsVar c)) args
659 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
660 checkPat loc e args -- OK to let this happen even if bang-patterns
661 -- are not enabled, because there is no valid
662 -- non-bang-pattern parse of (C ! e)
663 | Just (e', args') <- splitBang e
664 = do { args'' <- checkPatterns args'
665 ; checkPat loc e' (args'' ++ args) }
666 checkPat loc (L _ (HsApp f x)) args
667 = do { x <- checkLPat x; checkPat loc f (x:args) }
668 checkPat loc (L _ e) []
669 = do { pState <- getPState
670 ; p <- checkAPat (dflags pState) loc e
673 = patFail loc (unLoc e)
675 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
676 checkAPat dynflags loc e0 = case e0 of
677 EWildPat -> return (WildPat placeHolderType)
678 HsVar x -> return (VarPat x)
679 HsLit l -> return (LitPat l)
681 -- Overloaded numeric patterns (e.g. f 0 x = x)
682 -- Negation is recorded separately, so that the literal is zero or +ve
683 -- NB. Negative *primitive* literals are already handled by the lexer
684 HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
685 NegApp (L _ (HsOverLit pos_lit)) _
686 -> return (mkNPat pos_lit (Just noSyntaxExpr))
688 SectionR (L _ (HsVar bang)) e -- (! x)
690 -> do { bang_on <- extension bangPatEnabled
691 ; if bang_on then checkLPat e >>= (return . BangPat)
692 else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) }
694 ELazyPat e -> checkLPat e >>= (return . LazyPat)
695 EAsPat n e -> checkLPat e >>= (return . AsPat n)
696 -- view pattern is well-formed if the pattern is
697 EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
698 ExprWithTySig e t -> do e <- checkLPat e
699 -- Pattern signatures are parsed as sigtypes,
700 -- but they aren't explicit forall points. Hence
701 -- we have to remove the implicit forall here.
703 L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
705 return (SigPatIn e t')
708 OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
709 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
710 | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
711 -> return (mkNPlusKPat (L nloc n) lit)
713 OpApp l op _fix r -> do l <- checkLPat l
716 L cl (HsVar c) | isDataOcc (rdrNameOcc c)
717 -> return (ConPatIn (L cl c) (InfixCon l r))
720 HsPar e -> checkLPat e >>= (return . ParPat)
721 ExplicitList _ es -> do ps <- mapM checkLPat es
722 return (ListPat ps placeHolderType)
723 ExplicitPArr _ es -> do ps <- mapM checkLPat es
724 return (PArrPat ps placeHolderType)
727 | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es]
728 return (TuplePat ps b placeHolderType)
729 | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
731 RecordCon c _ (HsRecFields fs dd)
732 -> do fs <- mapM checkPatField fs
733 return (ConPatIn c (RecCon (HsRecFields fs dd)))
734 HsQuasiQuoteE q -> return (QuasiQuotePat q)
736 HsType ty -> return (TypePat ty)
739 placeHolderPunRhs :: LHsExpr RdrName
740 -- The RHS of a punned record field will be filled in by the renamer
741 -- It's better not to make it an error, in case we want to print it when debugging
742 placeHolderPunRhs = noLoc (HsVar pun_RDR)
744 plus_RDR, bang_RDR, pun_RDR :: RdrName
745 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
746 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
747 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
749 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
750 checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
751 ; return (fld { hsRecFieldArg = p }) }
753 patFail :: SrcSpan -> HsExpr RdrName -> P a
754 patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e)
757 ---------------------------------------------------------------------------
758 -- Check Equation Syntax
760 checkValDef :: LHsExpr RdrName
761 -> Maybe (LHsType RdrName)
762 -> Located (GRHSs RdrName)
763 -> P (HsBind RdrName)
765 checkValDef lhs (Just sig) grhss
766 -- x :: ty = rhs parses as a *pattern* binding
767 = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
769 checkValDef lhs opt_sig grhss
770 = do { mb_fun <- isFunLhs lhs
772 Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
773 fun is_infix pats opt_sig grhss
774 Nothing -> checkPatBind lhs grhss }
776 checkFunBind :: SrcSpan
780 -> Maybe (LHsType RdrName)
781 -> Located (GRHSs RdrName)
782 -> P (HsBind RdrName)
783 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
784 = do ps <- checkPatterns pats
785 let match_span = combineSrcSpans lhs_loc rhs_span
786 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
787 -- The span of the match covers the entire equation.
788 -- That isn't quite right, but it'll do for now.
790 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
791 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
792 makeFunBind fn is_infix ms
793 = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
794 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
796 checkPatBind :: LHsExpr RdrName
797 -> Located (GRHSs RdrName)
798 -> P (HsBind RdrName)
799 checkPatBind lhs (L _ grhss)
800 = do { lhs <- checkPattern lhs
801 ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
807 checkValSig (L l (HsVar v)) ty
808 | isUnqual v && not (isDataOcc (rdrNameOcc v))
809 = return (TypeSig (L l v) ty)
810 checkValSig lhs@(L l _) ty
811 = parseErrorSDoc l ((text "Invalid type signature:" <+>
812 ppr lhs <+> text "::" <+> ppr ty)
815 hint = if looks_like_foreign lhs
816 then "Perhaps you meant to use -XForeignFunctionInterface?"
817 else "Should be of form <variable> :: <type>"
818 -- A common error is to forget the ForeignFunctionInterface flag
819 -- so check for that, and suggest. cf Trac #3805
820 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
821 looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR
822 looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
823 looks_like_foreign _ = False
825 foreign_RDR = mkUnqual varName (fsLit "foreign")
827 checkDoAndIfThenElse :: LHsExpr RdrName
833 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
834 | semiThen || semiElse
835 = do pState <- getPState
836 unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do
837 parseErrorSDoc (combineLocs guardExpr elseExpr)
838 (text "Unexpected semi-colons in conditional:"
840 $$ text "Perhaps you meant to use -XDoAndIfThenElse?")
841 | otherwise = return ()
842 where pprOptSemi True = semi
843 pprOptSemi False = empty
844 expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
845 text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
846 text "else" <+> ppr elseExpr
851 -- The parser left-associates, so there should
852 -- not be any OpApps inside the e's
853 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
854 -- Splits (f ! g a b) into (f, [(! g), a, b])
855 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
856 | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
858 (arg1,argns) = split_bang r_arg []
859 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
860 split_bang e es = (e,es)
861 splitBang _ = Nothing
863 isFunLhs :: LHsExpr RdrName
864 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
865 -- A variable binding is parsed as a FunBind.
866 -- Just (fun, is_infix, arg_pats) if e is a function LHS
868 -- The whole LHS is parsed as a single expression.
869 -- Any infix operators on the LHS will parse left-associatively
871 -- will parse (rather strangely) as
873 -- It's up to isFunLhs to sort out the mess
879 go (L loc (HsVar f)) es
880 | not (isRdrDataCon f) = return (Just (L loc f, False, es))
881 go (L _ (HsApp f e)) es = go f (e:es)
882 go (L _ (HsPar e)) es@(_:_) = go e es
884 -- For infix function defns, there should be only one infix *function*
885 -- (though there may be infix *datacons* involved too). So we don't
886 -- need fixity info to figure out which function is being defined.
887 -- a `K1` b `op` c `K2` d
889 -- (a `K1` b) `op` (c `K2` d)
890 -- The renamer checks later that the precedences would yield such a parse.
892 -- There is a complication to deal with bang patterns.
894 -- ToDo: what about this?
895 -- x + 1 `op` y = ...
897 go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
898 | Just (e',es') <- splitBang e
899 = do { bang_on <- extension bangPatEnabled
900 ; if bang_on then go e' (es' ++ es)
901 else return (Just (L loc' op, True, (l:r:es))) }
902 -- No bangs; behave just like the next case
903 | not (isRdrDataCon op) -- We have found the function!
904 = return (Just (L loc' op, True, (l:r:es)))
905 | otherwise -- Infix data con; keep going
906 = do { mb_l <- go l es
908 Just (op', True, j : k : es')
909 -> return (Just (op', True, j : op_app : es'))
911 op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
912 _ -> return Nothing }
913 go _ _ = return Nothing
915 ---------------------------------------------------------------------------
916 -- Miscellaneous utilities
918 checkPrecP :: Located Int -> P Int
920 | 0 <= i && i <= maxPrecedence = return i
922 = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
927 -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
928 -> P (HsExpr RdrName)
930 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
931 = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
932 mkRecConstrOrUpdate exp loc (fs,dd)
933 | null fs = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp)
934 | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
936 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
937 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
938 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
940 mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
941 -- The Maybe is because the user can omit the activation spec (and usually does)
942 mkInlinePragma (inl, match_info) mb_act
943 = InlinePragma { inl_inline = inl
946 , inl_rule = match_info }
950 Nothing -> -- No phase specified
952 NoInline -> NeverActive
953 _other -> AlwaysActive
955 -----------------------------------------------------------------------------
956 -- utilities for foreign declarations
958 -- construct a foreign import declaration
960 mkImport :: CCallConv
962 -> (Located FastString, Located RdrName, LHsType RdrName)
963 -> P (HsDecl RdrName)
964 mkImport cconv safety (L loc entity, v, ty)
965 | cconv == PrimCallConv = do
966 let funcTarget = CFunction (StaticTarget entity Nothing)
967 importSpec = CImport PrimCallConv safety nilFS funcTarget
968 return (ForD (ForeignImport v ty importSpec))
971 case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
972 Nothing -> parseErrorSDoc loc (text "Malformed entity string")
973 Just importSpec -> return (ForD (ForeignImport v ty importSpec))
975 -- the string "foo" is ambigous: either a header or a C identifier. The
976 -- C identifier case comes first in the alternatives below, so we pick
978 parseCImport :: CCallConv -> Safety -> FastString -> String
979 -> Maybe ForeignImport
980 parseCImport cconv safety nm str =
981 listToMaybe $ map fst $ filter (null.snd) $
987 string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
988 string "wrapper" >> return (mk nilFS CWrapper),
989 optional (string "static" >> skipSpaces) >>
990 (mk nilFS <$> cimp nm) +++
991 (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
996 mk = CImport cconv safety
998 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
999 -- pretty much any char (depending on the platform),
1000 -- so just accept any non-space character
1001 id_char c = isAlphaNum c || c == '_'
1003 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1004 +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
1007 (do c <- satisfy (\c -> isAlpha c || c == '_')
1008 cs <- many (satisfy id_char)
1009 return (mkFastString (c:cs)))
1012 -- construct a foreign export declaration
1014 mkExport :: CCallConv
1015 -> (Located FastString, Located RdrName, LHsType RdrName)
1016 -> P (HsDecl RdrName)
1017 mkExport cconv (L _ entity, v, ty) = return $
1018 ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1020 entity' | nullFS entity = mkExtName (unLoc v)
1021 | otherwise = entity
1023 -- Supplying the ext_name in a foreign decl is optional; if it
1024 -- isn't there, the Haskell name is assumed. Note that no transformation
1025 -- of the Haskell name is then performed, so if you foreign export (++),
1026 -- it's external name will be "++". Too bad; it's important because we don't
1027 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1029 mkExtName :: RdrName -> CLabelString
1030 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1034 -----------------------------------------------------------------------------
1038 parseError :: SrcSpan -> String -> P a
1039 parseError span s = parseErrorSDoc span (text s)
1041 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1042 parseErrorSDoc span s = failSpanMsgP span s