Revert "Treat banged bindings as FunBinds"
[ghc.git] / compiler / parser / RdrHsSyn.hs
1 --
2 -- (c) The University of Glasgow 2002-2006
3 --
4
5 -- Functions over HsSyn specialised to RdrName.
6
7 {-# LANGUAGE CPP #-}
8 {-# LANGUAGE FlexibleContexts #-}
9
10 module RdrHsSyn (
11 mkHsOpApp,
12 mkHsIntegral, mkHsFractional, mkHsIsString,
13 mkHsDo, mkSpliceDecl,
14 mkRoleAnnotDecl,
15 mkClassDecl,
16 mkTyData, mkDataFamInst,
17 mkTySynonym, mkTyFamInstEqn,
18 mkTyFamInst,
19 mkFamDecl, mkLHsSigType,
20 splitCon, mkInlinePragma,
21 mkPatSynMatchGroup,
22 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
23 mkTyClD, mkInstD,
24 mkRdrRecordCon, mkRdrRecordUpd,
25 setRdrNameSpace,
26
27 cvBindGroup,
28 cvBindsAndSigs,
29 cvTopDecls,
30 placeHolderPunRhs,
31
32 -- Stuff to do with Foreign declarations
33 mkImport,
34 parseCImport,
35 mkExport,
36 mkExtName, -- RdrName -> CLabelString
37 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
38 mkConDeclH98,
39 mkATDefault,
40
41 -- Bunch of functions in the parser monad for
42 -- checking and constructing values
43 checkPrecP, -- Int -> P Int
44 checkContext, -- HsType -> P HsContext
45 checkPattern, -- HsExp -> P HsPat
46 bang_RDR,
47 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
48 checkMonadComp, -- P (HsStmtContext RdrName)
49 checkCommand, -- LHsExpr RdrName -> P (LHsCmd RdrName)
50 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
51 checkValSigLhs,
52 checkDoAndIfThenElse,
53 checkRecordSyntax,
54 parseErrorSDoc,
55 splitTilde, splitTildeApps,
56
57 -- Help with processing exports
58 ImpExpSubSpec(..),
59 ImpExpQcSpec(..),
60 mkModuleImpExp,
61 mkTypeImpExp,
62 mkImpExpSubSpec,
63 checkImportSpec,
64
65 SumOrTuple (..), mkSumOrTuple
66
67 ) where
68
69 import HsSyn -- Lots of it
70 import Class ( FunDep )
71 import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
72 import DataCon ( DataCon, dataConTyCon )
73 import ConLike ( ConLike(..) )
74 import CoAxiom ( Role, fsFromRole )
75 import RdrName
76 import Name
77 import BasicTypes
78 import TcEvidence ( idHsWrapper )
79 import Lexer
80 import Lexeme ( isLexCon )
81 import Type ( TyThing(..) )
82 import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon,
83 nilDataConName, nilDataConKey,
84 listTyConName, listTyConKey,
85 starKindTyConName, unicodeStarKindTyConName )
86 import ForeignCall
87 import PrelNames ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
88 import SrcLoc
89 import Unique ( hasKey )
90 import OrdList ( OrdList, fromOL )
91 import Bag ( emptyBag, consBag )
92 import Outputable
93 import FastString
94 import Maybes
95 import Util
96 import ApiAnnotation
97 import Data.List
98 import qualified GHC.LanguageExtensions as LangExt
99 import MonadUtils
100
101 import Control.Monad
102 import Text.ParserCombinators.ReadP as ReadP
103 import Data.Char
104
105 import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
106
107 #include "HsVersions.h"
108
109
110 {- **********************************************************************
111
112 Construction functions for Rdr stuff
113
114 ********************************************************************* -}
115
116 -- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and
117 -- datacon by deriving them from the name of the class. We fill in the names
118 -- for the tycon and datacon corresponding to the class, by deriving them
119 -- from the name of the class itself. This saves recording the names in the
120 -- interface file (which would be equally good).
121
122 -- Similarly for mkConDecl, mkClassOpSig and default-method names.
123
124 -- *** See Note [The Naming story] in HsDecls ****
125
126 mkTyClD :: LTyClDecl n -> LHsDecl n
127 mkTyClD (L loc d) = L loc (TyClD d)
128
129 mkInstD :: LInstDecl n -> LHsDecl n
130 mkInstD (L loc d) = L loc (InstD d)
131
132 mkClassDecl :: SrcSpan
133 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
134 -> Located (a,[Located (FunDep (Located RdrName))])
135 -> OrdList (LHsDecl RdrName)
136 -> P (LTyClDecl RdrName)
137
138 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
139 = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
140 ; let cxt = fromMaybe (noLoc []) mcxt
141 ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
142 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
143 ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
144 ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
145 ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars
146 , tcdFixity = fixity
147 , tcdFDs = snd (unLoc fds)
148 , tcdSigs = mkClassOpSigs sigs
149 , tcdMeths = binds
150 , tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs
151 , tcdFVs = placeHolderNames })) }
152
153 mkATDefault :: LTyFamInstDecl RdrName
154 -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName)
155 -- Take a type-family instance declaration and turn it into
156 -- a type-family default equation for a class declaration
157 -- We parse things as the former and use this function to convert to the latter
158 --
159 -- We use the Either monad because this also called
160 -- from Convert.hs
161 mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
162 | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity
163 , tfe_rhs = rhs } <- e
164 = do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats)
165 ; return (L loc (TyFamEqn { tfe_tycon = tc
166 , tfe_pats = tvs
167 , tfe_fixity = fixity
168 , tfe_rhs = rhs })) }
169
170 mkTyData :: SrcSpan
171 -> NewOrData
172 -> Maybe (Located CType)
173 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
174 -> Maybe (LHsKind RdrName)
175 -> [LConDecl RdrName]
176 -> HsDeriving RdrName
177 -> P (LTyClDecl RdrName)
178 mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
179 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
180 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
181 ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
182 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
183 ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
184 tcdFixity = fixity,
185 tcdDataDefn = defn,
186 tcdDataCusk = PlaceHolder,
187 tcdFVs = placeHolderNames })) }
188
189 mkDataDefn :: NewOrData
190 -> Maybe (Located CType)
191 -> Maybe (LHsContext RdrName)
192 -> Maybe (LHsKind RdrName)
193 -> [LConDecl RdrName]
194 -> HsDeriving RdrName
195 -> P (HsDataDefn RdrName)
196 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
197 = do { checkDatatypeContext mcxt
198 ; let cxt = fromMaybe (noLoc []) mcxt
199 ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
200 , dd_ctxt = cxt
201 , dd_cons = data_cons
202 , dd_kindSig = ksig
203 , dd_derivs = maybe_deriv }) }
204
205
206 mkTySynonym :: SrcSpan
207 -> LHsType RdrName -- LHS
208 -> LHsType RdrName -- RHS
209 -> P (LTyClDecl RdrName)
210 mkTySynonym loc lhs rhs
211 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
212 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
213 ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
214 ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars
215 , tcdFixity = fixity
216 , tcdRhs = rhs, tcdFVs = placeHolderNames })) }
217
218 mkTyFamInstEqn :: LHsType RdrName
219 -> LHsType RdrName
220 -> P (TyFamInstEqn RdrName,[AddAnn])
221 mkTyFamInstEqn lhs rhs
222 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
223 ; return (TyFamEqn { tfe_tycon = tc
224 , tfe_pats = mkHsImplicitBndrs tparams
225 , tfe_fixity = fixity
226 , tfe_rhs = rhs },
227 ann) }
228
229 mkDataFamInst :: SrcSpan
230 -> NewOrData
231 -> Maybe (Located CType)
232 -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
233 -> Maybe (LHsKind RdrName)
234 -> [LConDecl RdrName]
235 -> HsDeriving RdrName
236 -> P (LInstDecl RdrName)
237 mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
238 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
239 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
240 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
241 ; return (L loc (DataFamInstD (
242 DataFamInstDecl { dfid_tycon = tc
243 , dfid_pats = mkHsImplicitBndrs tparams
244 , dfid_fixity = fixity
245 , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
246
247 mkTyFamInst :: SrcSpan
248 -> LTyFamInstEqn RdrName
249 -> P (LInstDecl RdrName)
250 mkTyFamInst loc eqn
251 = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn
252 , tfid_fvs = placeHolderNames })))
253
254 mkFamDecl :: SrcSpan
255 -> FamilyInfo RdrName
256 -> LHsType RdrName -- LHS
257 -> Located (FamilyResultSig RdrName) -- Optional result signature
258 -> Maybe (LInjectivityAnn RdrName) -- Injectivity annotation
259 -> P (LTyClDecl RdrName)
260 mkFamDecl loc info lhs ksig injAnn
261 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
262 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
263 ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
264 ; return (L loc (FamDecl (FamilyDecl{ fdInfo = info, fdLName = tc
265 , fdTyVars = tyvars
266 , fdFixity = fixity
267 , fdResultSig = ksig
268 , fdInjectivityAnn = injAnn }))) }
269 where
270 equals_or_where = case info of
271 DataFamily -> empty
272 OpenTypeFamily -> empty
273 ClosedTypeFamily {} -> whereDots
274
275 mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
276 -- If the user wrote
277 -- [pads| ... ] then return a QuasiQuoteD
278 -- $(e) then return a SpliceD
279 -- but if she wrote, say,
280 -- f x then behave as if she'd written $(f x)
281 -- ie a SpliceD
282 --
283 -- Typed splices are not allowed at the top level, thus we do not represent them
284 -- as spliced declaration. See #10945
285 mkSpliceDecl lexpr@(L loc expr)
286 | HsSpliceE splice@(HsUntypedSplice {}) <- expr
287 = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
288
289 | HsSpliceE splice@(HsQuasiQuote {}) <- expr
290 = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
291
292 | otherwise
293 = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice)
294
295 mkRoleAnnotDecl :: SrcSpan
296 -> Located RdrName -- type being annotated
297 -> [Located (Maybe FastString)] -- roles
298 -> P (LRoleAnnotDecl RdrName)
299 mkRoleAnnotDecl loc tycon roles
300 = do { roles' <- mapM parse_role roles
301 ; return $ L loc $ RoleAnnotDecl tycon roles' }
302 where
303 role_data_type = dataTypeOf (undefined :: Role)
304 all_roles = map fromConstr $ dataTypeConstrs role_data_type
305 possible_roles = [(fsFromRole role, role) | role <- all_roles]
306
307 parse_role (L loc_role Nothing) = return $ L loc_role Nothing
308 parse_role (L loc_role (Just role))
309 = case lookup role possible_roles of
310 Just found_role -> return $ L loc_role $ Just found_role
311 Nothing ->
312 let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
313 parseErrorSDoc loc_role
314 (text "Illegal role name" <+> quotes (ppr role) $$
315 suggestions nearby)
316
317 suggestions [] = empty
318 suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r)
319 -- will this last case ever happen??
320 suggestions list = hang (text "Perhaps you meant one of these:")
321 2 (pprWithCommas (quotes . ppr) list)
322
323 {- **********************************************************************
324
325 #cvBinds-etc# Converting to @HsBinds@, etc.
326
327 ********************************************************************* -}
328
329 -- | Function definitions are restructured here. Each is assumed to be recursive
330 -- initially, and non recursive definitions are discovered by the dependency
331 -- analyser.
332
333
334 -- | Groups together bindings for a single function
335 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
336 cvTopDecls decls = go (fromOL decls)
337 where
338 go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
339 go [] = []
340 go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
341 where (L l' b', ds') = getMonoBind (L l b) ds
342 go (d : ds) = d : go ds
343
344 -- Declaration list may only contain value bindings and signatures.
345 cvBindGroup :: OrdList (LHsDecl RdrName) -> P (HsValBinds RdrName)
346 cvBindGroup binding
347 = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
348 ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
349 return $ ValBindsIn mbs sigs }
350
351 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
352 -> P (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName]
353 , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl])
354 -- Input decls contain just value bindings and signatures
355 -- and in case of class or instance declarations also
356 -- associated type declarations. They might also contain Haddock comments.
357 cvBindsAndSigs fb = go (fromOL fb)
358 where
359 go [] = return (emptyBag, [], [], [], [], [])
360 go (L l (ValD b) : ds)
361 = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
362 ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
363 where
364 (b', ds') = getMonoBind (L l b) ds
365 go (L l decl : ds)
366 = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
367 ; case decl of
368 SigD s
369 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
370 TyClD (FamDecl t)
371 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
372 InstD (TyFamInstD { tfid_inst = tfi })
373 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
374 InstD (DataFamInstD { dfid_inst = dfi })
375 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
376 DocD d
377 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
378 SpliceD d
379 -> parseErrorSDoc l $
380 hang (text "Declaration splices are allowed only" <+>
381 text "at the top level:")
382 2 (ppr d)
383 _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
384
385 -----------------------------------------------------------------------------
386 -- Group function bindings into equation groups
387
388 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
389 -> (LHsBind RdrName, [LHsDecl RdrName])
390 -- Suppose (b',ds') = getMonoBind b ds
391 -- ds is a list of parsed bindings
392 -- b is a MonoBinds that has just been read off the front
393
394 -- Then b' is the result of grouping more equations from ds that
395 -- belong with b into a single MonoBinds, and ds' is the depleted
396 -- list of parsed bindings.
397 --
398 -- All Haddock comments between equations inside the group are
399 -- discarded.
400 --
401 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
402
403 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
404 fun_matches
405 = MG { mg_alts = L _ mtchs1 } })) binds
406 | has_args mtchs1
407 = go mtchs1 loc1 binds []
408 where
409 go mtchs loc
410 (L loc2 (ValD (FunBind { fun_id = L _ f2,
411 fun_matches
412 = MG { mg_alts = L _ mtchs2 } })) : binds) _
413 | f1 == f2 = go (mtchs2 ++ mtchs)
414 (combineSrcSpans loc loc2) binds []
415 go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
416 = let doc_decls' = doc_decl : doc_decls
417 in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
418 go mtchs loc binds doc_decls
419 = ( L loc (makeFunBind fun_id1 (reverse mtchs))
420 , (reverse doc_decls) ++ binds)
421 -- Reverse the final matches, to get it back in the right order
422 -- Do the same thing with the trailing doc comments
423
424 getMonoBind bind binds = (bind, binds)
425
426 has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool
427 has_args [] = panic "RdrHsSyn:has_args"
428 has_args ((L _ (Match _ args _ _)) : _) = not (null args)
429 -- Don't group together FunBinds if they have
430 -- no arguments. This is necessary now that variable bindings
431 -- with no arguments are now treated as FunBinds rather
432 -- than pattern bindings (tests/rename/should_fail/rnfail002).
433
434 {- **********************************************************************
435
436 #PrefixToHS-utils# Utilities for conversion
437
438 ********************************************************************* -}
439
440 {- Note [Parsing data constructors is hard]
441 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
442 We parse the RHS of the constructor declaration
443 data T = C t1 t2
444 as a btype_no_ops (treating C as a type constructor) and then convert C to be
445 a data constructor. Reason: it might continue like this:
446 data T = C t1 t2 :% D Int
447 in which case C really /would/ be a type constructor. We can't resolve this
448 ambiguity till we come across the constructor oprerator :% (or not, more usually)
449
450 So the plan is:
451
452 * Parse the data constructor declration as a type (actually btype_no_ops)
453
454 * Use 'splitCon' to rejig it into the data constructor and the args
455
456 * In doing so, we use 'tyConToDataCon' to convert the RdrName for
457 the data con, which has been parsed as a tycon, back to a datacon.
458 This is more than just adjusting the name space; for operators we
459 need to check that it begins with a colon. E.g.
460 data T = (+++)
461 will parse ok (since tycons can be operators), but we should reject
462 it (Trac #12051).
463 -}
464
465 splitCon :: LHsType RdrName
466 -> P (Located RdrName, HsConDeclDetails RdrName)
467 -- See Note [Parsing data constructors is hard]
468 -- This gets given a "type" that should look like
469 -- C Int Bool
470 -- or C { x::Int, y::Bool }
471 -- and returns the pieces
472 splitCon ty
473 = split ty []
474 where
475 -- This is used somewhere where HsAppsTy is not used
476 split (L _ (HsAppTy t u)) ts = split t (u : ts)
477 split (L l (HsTyVar _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc
478 return (data_con, mk_rest ts)
479 split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
480 = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
481 split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
482
483 mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
484 mk_rest ts = PrefixCon ts
485
486 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
487 -- See Note [Parsing data constructors is hard]
488 -- Data constructor RHSs are parsed as types
489 tyConToDataCon loc tc
490 | isTcOcc occ
491 , isLexCon (occNameFS occ)
492 = return (L loc (setRdrNameSpace tc srcDataName))
493
494 | otherwise
495 = parseErrorSDoc loc (msg $$ extra)
496 where
497 occ = rdrNameOcc tc
498
499 msg = text "Not a data constructor:" <+> quotes (ppr tc)
500 extra | tc == forall_tv_RDR
501 = text "Perhaps you intended to use ExistentialQuantification"
502 | otherwise = empty
503
504 mkPatSynMatchGroup :: Located RdrName
505 -> Located (OrdList (LHsDecl RdrName))
506 -> P (MatchGroup RdrName (LHsExpr RdrName))
507 mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
508 do { matches <- mapM fromDecl (fromOL decls)
509 ; when (null matches) (wrongNumberErr loc)
510 ; return $ mkMatchGroup FromSource matches }
511 where
512 fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) =
513 do { unless (name == patsyn_name) $
514 wrongNameBindingErr loc decl
515 ; match <- case details of
516 PrefixCon pats ->
517 return $ Match (FunRhs ln Prefix) pats Nothing rhs
518 InfixCon pat1 pat2 ->
519 return $ Match (FunRhs ln Infix) [pat1, pat2] Nothing rhs
520 RecCon{} -> recordPatSynErr loc pat
521 ; return $ L loc match }
522 fromDecl (L loc decl) = extraDeclErr loc decl
523
524 extraDeclErr loc decl =
525 parseErrorSDoc loc $
526 text "pattern synonym 'where' clause must contain a single binding:" $$
527 ppr decl
528
529 wrongNameBindingErr loc decl =
530 parseErrorSDoc loc $
531 text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
532 quotes (ppr patsyn_name) $$ ppr decl
533
534 wrongNumberErr loc =
535 parseErrorSDoc loc $
536 text "pattern synonym 'where' clause cannot be empty" $$
537 text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
538
539 recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
540 recordPatSynErr loc pat =
541 parseErrorSDoc loc $
542 text "record syntax not supported for pattern synonym declarations:" $$
543 ppr pat
544
545 mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
546 -> LHsContext RdrName -> HsConDeclDetails RdrName
547 -> ConDecl RdrName
548
549 mkConDeclH98 name mb_forall cxt details
550 = ConDeclH98 { con_name = name
551 , con_qvars = fmap mkHsQTvs mb_forall
552 , con_cxt = Just cxt
553 -- AZ:TODO: when can cxt be Nothing?
554 -- remembering that () is a valid context.
555 , con_details = details
556 , con_doc = Nothing }
557
558 mkGadtDecl :: [Located RdrName]
559 -> LHsSigType RdrName -- Always a HsForAllTy
560 -> ConDecl RdrName
561 mkGadtDecl names ty = ConDeclGADT { con_names = names
562 , con_type = ty
563 , con_doc = Nothing }
564
565 setRdrNameSpace :: RdrName -> NameSpace -> RdrName
566 -- ^ This rather gruesome function is used mainly by the parser.
567 -- When parsing:
568 --
569 -- > data T a = T | T1 Int
570 --
571 -- we parse the data constructors as /types/ because of parser ambiguities,
572 -- so then we need to change the /type constr/ to a /data constr/
573 --
574 -- The exact-name case /can/ occur when parsing:
575 --
576 -- > data [] a = [] | a : [a]
577 --
578 -- For the exact-name case we return an original name.
579 setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
580 setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
581 setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
582 setRdrNameSpace (Exact n) ns
583 | Just thing <- wiredInNameTyThing_maybe n
584 = setWiredInNameSpace thing ns
585 -- Preserve Exact Names for wired-in things,
586 -- notably tuples and lists
587
588 | isExternalName n
589 = Orig (nameModule n) occ
590
591 | otherwise -- This can happen when quoting and then
592 -- splicing a fixity declaration for a type
593 = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
594 where
595 occ = setOccNameSpace ns (nameOccName n)
596
597 setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
598 setWiredInNameSpace (ATyCon tc) ns
599 | isDataConNameSpace ns
600 = ty_con_data_con tc
601 | isTcClsNameSpace ns
602 = Exact (getName tc) -- No-op
603
604 setWiredInNameSpace (AConLike (RealDataCon dc)) ns
605 | isTcClsNameSpace ns
606 = data_con_ty_con dc
607 | isDataConNameSpace ns
608 = Exact (getName dc) -- No-op
609
610 setWiredInNameSpace thing ns
611 = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)
612
613 ty_con_data_con :: TyCon -> RdrName
614 ty_con_data_con tc
615 | isTupleTyCon tc
616 , Just dc <- tyConSingleDataCon_maybe tc
617 = Exact (getName dc)
618
619 | tc `hasKey` listTyConKey
620 = Exact nilDataConName
621
622 | otherwise -- See Note [setRdrNameSpace for wired-in names]
623 = Unqual (setOccNameSpace srcDataName (getOccName tc))
624
625 data_con_ty_con :: DataCon -> RdrName
626 data_con_ty_con dc
627 | let tc = dataConTyCon dc
628 , isTupleTyCon tc
629 = Exact (getName tc)
630
631 | dc `hasKey` nilDataConKey
632 = Exact listTyConName
633
634 | otherwise -- See Note [setRdrNameSpace for wired-in names]
635 = Unqual (setOccNameSpace tcClsName (getOccName dc))
636
637
638 {- Note [setRdrNameSpace for wired-in names]
639 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
640 In GHC.Types, which declares (:), we have
641 infixr 5 :
642 The ambiguity about which ":" is meant is resolved by parsing it as a
643 data constructor, but then using dataTcOccs to try the type constructor too;
644 and that in turn calls setRdrNameSpace to change the name-space of ":" to
645 tcClsName. There isn't a corresponding ":" type constructor, but it's painful
646 to make setRdrNameSpace partial, so we just make an Unqual name instead. It
647 really doesn't matter!
648 -}
649
650 -- | Note [Sorting out the result type]
651 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
652 -- In a GADT declaration which is not a record, we put the whole constr type
653 -- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once
654 -- it has sorted out operator fixities. Consider for example
655 -- C :: a :*: b -> a :*: b -> a :+: b
656 -- Initially this type will parse as
657 -- a :*: (b -> (a :*: (b -> (a :+: b))))
658 --
659 -- so it's hard to split up the arguments until we've done the precedence
660 -- resolution (in the renamer). On the other hand, for a record
661 -- { x,y :: Int } -> a :*: b
662 -- there is no doubt. AND we need to sort records out so that
663 -- we can bring x,y into scope. So:
664 -- * For PrefixCon we keep all the args in the res_ty
665 -- * For RecCon we do not
666
667 checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName)
668 -- Same as checkTyVars, but in the P monad
669 checkTyVarsP pp_what equals_or_where tc tparms
670 = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
671
672 eitherToP :: Either (SrcSpan, SDoc) a -> P a
673 -- Adapts the Either monad to the P monad
674 eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
675 eitherToP (Right thing) = return thing
676
677 checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName]
678 -> Either (SrcSpan, SDoc) (LHsQTyVars RdrName)
679 -- Check whether the given list of type parameters are all type variables
680 -- (possibly with a kind signature)
681 -- We use the Either monad because it's also called (via mkATDefault) from
682 -- Convert.hs
683 checkTyVars pp_what equals_or_where tc tparms
684 = do { tvs <- mapM chk tparms
685 ; return (mkHsQTvs tvs) }
686 where
687
688 chk (L _ (HsParTy ty)) = chk ty
689 chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty
690
691 -- Check that the name space is correct!
692 chk (L l (HsKindSig
693 (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))
694 | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k))
695 chk (L l (HsTyVar _ (L ltv tv)))
696 | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv)))
697 chk t@(L loc _)
698 = Left (loc,
699 vcat [ text "Unexpected type" <+> quotes (ppr t)
700 , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
701 , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form"))
702 , nest 2 (pp_what <+> ppr tc
703 <+> hsep (map text (takeList tparms allNameStrings))
704 <+> equals_or_where) ] ])
705
706 whereDots, equalsDots :: SDoc
707 -- Second argument to checkTyVars
708 whereDots = text "where ..."
709 equalsDots = text "= ..."
710
711 checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
712 checkDatatypeContext Nothing = return ()
713 checkDatatypeContext (Just (L loc c))
714 = do allowed <- extension datatypeContextsEnabled
715 unless allowed $
716 parseErrorSDoc loc
717 (text "Illegal datatype context (use DatatypeContexts):" <+>
718 pprHsContext c)
719
720 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
721 checkRecordSyntax lr@(L loc r)
722 = do allowed <- extension traditionalRecordSyntaxEnabled
723 if allowed
724 then return lr
725 else parseErrorSDoc loc
726 (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
727 ppr r)
728
729 checkTyClHdr :: Bool -- True <=> class header
730 -- False <=> type header
731 -> LHsType RdrName
732 -> P (Located RdrName, -- the head symbol (type or class name)
733 [LHsType RdrName], -- parameters of head symbol
734 LexicalFixity, -- the declaration is in infix format
735 [AddAnn]) -- API Annotation for HsParTy when stripping parens
736 -- Well-formedness check and decomposition of type and class heads.
737 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
738 -- Int :*: Bool into (:*:, [Int, Bool])
739 -- returning the pieces
740 checkTyClHdr is_cls ty
741 = goL ty [] [] Prefix
742 where
743 goL (L l ty) acc ann fix = go l ty acc ann fix
744
745 go l (HsTyVar _ (L _ tc)) acc ann fix
746 | isRdrTc tc = return (L l tc, acc, fix, ann)
747 go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix
748 | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann)
749 go l (HsParTy ty) acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix
750 go _ (HsAppTy t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
751 go _ (HsAppsTy ts) acc ann _fix
752 | Just (head, args, fixity) <- getAppsTyHead_maybe ts
753 = goL head (args ++ acc) ann fixity
754
755 go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix
756 | isStar star
757 = return (L loc (nameRdrName starKindTyConName), [], fix, ann)
758 | isUniStar star
759 = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann)
760
761 go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix
762 = return (L l (nameRdrName tup_name), ts, fix, ann)
763 where
764 arity = length ts
765 tup_name | is_cls = cTupleTyConName arity
766 | otherwise = getName (tupleTyCon Boxed arity)
767 -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?)
768 go l _ _ _ _
769 = parseErrorSDoc l (text "Malformed head of type or class declaration:"
770 <+> ppr ty)
771
772 checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName)
773 checkContext (L l orig_t)
774 = check [] (L l orig_t)
775 where
776 check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type
777 = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
778
779 -- don't let HsAppsTy get in the way
780 check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)]))
781 = check anns ty
782
783 check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
784 = check anns' ty
785 where anns' = if l == lp1 then anns
786 else (anns ++ mkParensApiAnn lp1)
787
788 check _anns _
789 = return ([],L l [L l orig_t]) -- no need for anns, returning original
790
791 -- -------------------------------------------------------------------------
792 -- Checking Patterns.
793
794 -- We parse patterns as expressions and check for valid patterns below,
795 -- converting the expression into a pattern at the same time.
796
797 checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
798 checkPattern msg e = checkLPat msg e
799
800 checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName]
801 checkPatterns msg es = mapM (checkPattern msg) es
802
803 checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
804 checkLPat msg e@(L l _) = checkPat msg l e []
805
806 checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
807 -> P (LPat RdrName)
808 checkPat _ loc (L l e@(HsVar (L _ c))) args
809 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
810 | not (null args) && patIsRec c =
811 patFail (text "Perhaps you intended to use RecursiveDo") l e
812 checkPat msg loc e args -- OK to let this happen even if bang-patterns
813 -- are not enabled, because there is no valid
814 -- non-bang-pattern parse of (C ! e)
815 | Just (e', args') <- splitBang e
816 = do { args'' <- checkPatterns msg args'
817 ; checkPat msg loc e' (args'' ++ args) }
818 checkPat msg loc (L _ (HsApp f e)) args
819 = do p <- checkLPat msg e
820 checkPat msg loc f (p : args)
821 checkPat msg loc (L _ e) []
822 = do p <- checkAPat msg loc e
823 return (L loc p)
824 checkPat msg loc e _
825 = patFail msg loc (unLoc e)
826
827 checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
828 checkAPat msg loc e0 = do
829 pState <- getPState
830 let opts = options pState
831 case e0 of
832 EWildPat -> return (WildPat placeHolderType)
833 HsVar x -> return (VarPat x)
834 HsLit (HsStringPrim _ _) -- (#13260)
835 -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)
836
837 HsLit l -> return (LitPat l)
838
839 -- Overloaded numeric patterns (e.g. f 0 x = x)
840 -- Negation is recorded separately, so that the literal is zero or +ve
841 -- NB. Negative *primitive* literals are already handled by the lexer
842 HsOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
843 NegApp (L l (HsOverLit pos_lit)) _
844 -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
845
846 SectionR (L lb (HsVar (L _ bang))) e -- (! x)
847 | bang == bang_RDR
848 -> do { bang_on <- extension bangPatEnabled
849 ; if bang_on then do { e' <- checkLPat msg e
850 ; addAnnotation loc AnnBang lb
851 ; return (BangPat e') }
852 else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
853
854 ELazyPat e -> checkLPat msg e >>= (return . LazyPat)
855 EAsPat n e -> checkLPat msg e >>= (return . AsPat n)
856 -- view pattern is well-formed if the pattern is
857 EViewPat expr patE -> checkLPat msg patE >>=
858 (return . (\p -> ViewPat expr p placeHolderType))
859 ExprWithTySig e t -> do e <- checkLPat msg e
860 return (SigPatIn e t)
861
862 -- n+k patterns
863 OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _
864 (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
865 | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
866 -> return (mkNPlusKPat (L nloc n) (L lloc lit))
867
868 OpApp l op _fix r -> do l <- checkLPat msg l
869 r <- checkLPat msg r
870 case op of
871 L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c)
872 -> return (ConPatIn (L cl c) (InfixCon l r))
873 _ -> patFail msg loc e0
874
875 HsPar e -> checkLPat msg e >>= (return . ParPat)
876 ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
877 return (ListPat ps placeHolderType Nothing)
878 ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es
879 return (PArrPat ps placeHolderType)
880
881 ExplicitTuple es b
882 | all tupArgPresent es -> do ps <- mapM (checkLPat msg)
883 [e | L _ (Present e) <- es]
884 return (TuplePat ps b [])
885 | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
886
887 ExplicitSum alt arity expr _ -> do
888 p <- checkLPat msg expr
889 return (SumPat p alt arity placeHolderType)
890
891 RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
892 -> do fs <- mapM (checkPatField msg) fs
893 return (ConPatIn c (RecCon (HsRecFields fs dd)))
894 HsSpliceE s | not (isTypedSplice s)
895 -> return (SplicePat s)
896 _ -> patFail msg loc e0
897
898 placeHolderPunRhs :: LHsExpr RdrName
899 -- The RHS of a punned record field will be filled in by the renamer
900 -- It's better not to make it an error, in case we want to print it when debugging
901 placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR))
902
903 plus_RDR, bang_RDR, pun_RDR :: RdrName
904 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
905 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
906 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
907
908 checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName)
909 -> P (LHsRecField RdrName (LPat RdrName))
910 checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
911 return (L l (fld { hsRecFieldArg = p }))
912
913 patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a
914 patFail msg loc e = parseErrorSDoc loc err
915 where err = text "Parse error in pattern:" <+> ppr e
916 $$ msg
917
918 patIsRec :: RdrName -> Bool
919 patIsRec e = e == mkUnqual varName (fsLit "rec")
920
921
922 ---------------------------------------------------------------------------
923 -- Check Equation Syntax
924
925 checkValDef :: SDoc
926 -> LHsExpr RdrName
927 -> Maybe (LHsType RdrName)
928 -> Located (a,GRHSs RdrName (LHsExpr RdrName))
929 -> P ([AddAnn],HsBind RdrName)
930
931 checkValDef msg lhs (Just sig) grhss
932 -- x :: ty = rhs parses as a *pattern* binding
933 = checkPatBind msg (L (combineLocs lhs sig)
934 (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
935
936 checkValDef msg lhs opt_sig g@(L l (_,grhss))
937 = do { mb_fun <- isFunLhs lhs
938 ; case mb_fun of
939 Just (fun, is_infix, pats, ann) ->
940 checkFunBind msg ann (getLoc lhs)
941 fun is_infix pats opt_sig (L l grhss)
942 Nothing -> checkPatBind msg lhs g }
943
944 checkFunBind :: SDoc
945 -> [AddAnn]
946 -> SrcSpan
947 -> Located RdrName
948 -> LexicalFixity
949 -> [LHsExpr RdrName]
950 -> Maybe (LHsType RdrName)
951 -> Located (GRHSs RdrName (LHsExpr RdrName))
952 -> P ([AddAnn],HsBind RdrName)
953 checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
954 = do ps <- checkPatterns msg pats
955 let match_span = combineSrcSpans lhs_loc rhs_span
956 -- Add back the annotations stripped from any HsPar values in the lhs
957 -- mapM_ (\a -> a match_span) ann
958 return (ann, makeFunBind fun
959 [L match_span (Match { m_ctxt = FunRhs fun is_infix
960 , m_pats = ps
961 , m_type = opt_sig
962 , m_grhss = grhss })])
963 -- The span of the match covers the entire equation.
964 -- That isn't quite right, but it'll do for now.
965
966 makeFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
967 -> HsBind RdrName
968 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
969 makeFunBind fn ms
970 = FunBind { fun_id = fn,
971 fun_matches = mkMatchGroup FromSource ms,
972 fun_co_fn = idHsWrapper,
973 bind_fvs = placeHolderNames,
974 fun_tick = [] }
975
976 checkPatBind :: SDoc
977 -> LHsExpr RdrName
978 -> Located (a,GRHSs RdrName (LHsExpr RdrName))
979 -> P ([AddAnn],HsBind RdrName)
980 checkPatBind msg lhs (L _ (_,grhss))
981 = do { lhs <- checkPattern msg lhs
982 ; return ([],PatBind lhs grhss placeHolderType placeHolderNames
983 ([],[])) }
984
985 checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName)
986 checkValSigLhs (L _ (HsVar lrdr@(L _ v)))
987 | isUnqual v
988 , not (isDataOcc (rdrNameOcc v))
989 = return lrdr
990
991 checkValSigLhs lhs@(L l _)
992 = parseErrorSDoc l ((text "Invalid type signature:" <+>
993 ppr lhs <+> text ":: ...")
994 $$ text hint)
995 where
996 hint | foreign_RDR `looks_like` lhs
997 = "Perhaps you meant to use ForeignFunctionInterface?"
998 | default_RDR `looks_like` lhs
999 = "Perhaps you meant to use DefaultSignatures?"
1000 | pattern_RDR `looks_like` lhs
1001 = "Perhaps you meant to use PatternSynonyms?"
1002 | otherwise
1003 = "Should be of form <variable> :: <type>"
1004
1005 -- A common error is to forget the ForeignFunctionInterface flag
1006 -- so check for that, and suggest. cf Trac #3805
1007 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
1008 looks_like s (L _ (HsVar (L _ v))) = v == s
1009 looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
1010 looks_like _ _ = False
1011
1012 foreign_RDR = mkUnqual varName (fsLit "foreign")
1013 default_RDR = mkUnqual varName (fsLit "default")
1014 pattern_RDR = mkUnqual varName (fsLit "pattern")
1015
1016
1017 checkDoAndIfThenElse :: LHsExpr RdrName
1018 -> Bool
1019 -> LHsExpr RdrName
1020 -> Bool
1021 -> LHsExpr RdrName
1022 -> P ()
1023 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
1024 | semiThen || semiElse
1025 = do pState <- getPState
1026 unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do
1027 parseErrorSDoc (combineLocs guardExpr elseExpr)
1028 (text "Unexpected semi-colons in conditional:"
1029 $$ nest 4 expr
1030 $$ text "Perhaps you meant to use DoAndIfThenElse?")
1031 | otherwise = return ()
1032 where pprOptSemi True = semi
1033 pprOptSemi False = empty
1034 expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
1035 text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
1036 text "else" <+> ppr elseExpr
1037
1038
1039 -- The parser left-associates, so there should
1040 -- not be any OpApps inside the e's
1041 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
1042 -- Splits (f ! g a b) into (f, [(! g), a, b])
1043 splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg))
1044 | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
1045 where
1046 l' = combineLocs bang arg1
1047 (arg1,argns) = split_bang r_arg []
1048 split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
1049 split_bang e es = (e,es)
1050 splitBang _ = Nothing
1051
1052 isFunLhs :: LHsExpr RdrName
1053 -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr RdrName],[AddAnn]))
1054 -- A variable binding is parsed as a FunBind.
1055 -- Just (fun, is_infix, arg_pats) if e is a function LHS
1056 --
1057 -- The whole LHS is parsed as a single expression.
1058 -- Any infix operators on the LHS will parse left-associatively
1059 -- E.g. f !x y !z
1060 -- will parse (rather strangely) as
1061 -- (f ! x y) ! z
1062 -- It's up to isFunLhs to sort out the mess
1063 --
1064 -- a .!. !b
1065
1066 isFunLhs e = go e [] []
1067 where
1068 go (L loc (HsVar (L _ f))) es ann
1069 | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
1070 go (L _ (HsApp f e)) es ann = go f (e:es) ann
1071 go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
1072
1073 -- For infix function defns, there should be only one infix *function*
1074 -- (though there may be infix *datacons* involved too). So we don't
1075 -- need fixity info to figure out which function is being defined.
1076 -- a `K1` b `op` c `K2` d
1077 -- must parse as
1078 -- (a `K1` b) `op` (c `K2` d)
1079 -- The renamer checks later that the precedences would yield such a parse.
1080 --
1081 -- There is a complication to deal with bang patterns.
1082 --
1083 -- ToDo: what about this?
1084 -- x + 1 `op` y = ...
1085
1086 go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann
1087 | Just (e',es') <- splitBang e
1088 = do { bang_on <- extension bangPatEnabled
1089 ; if bang_on then go e' (es' ++ es) ann
1090 else return (Just (L loc' op, Infix, (l:r:es), ann)) }
1091 -- No bangs; behave just like the next case
1092 | not (isRdrDataCon op) -- We have found the function!
1093 = return (Just (L loc' op, Infix, (l:r:es), ann))
1094 | otherwise -- Infix data con; keep going
1095 = do { mb_l <- go l es ann
1096 ; case mb_l of
1097 Just (op', Infix, j : k : es', ann')
1098 -> return (Just (op', Infix, j : op_app : es', ann'))
1099 where
1100 op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r)
1101 _ -> return Nothing }
1102 go _ _ _ = return Nothing
1103
1104
1105 -- | Transform btype_no_ops with strict_mark's into HsEqTy's
1106 -- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
1107 splitTilde :: LHsType RdrName -> P (LHsType RdrName)
1108 splitTilde t = go t
1109 where go (L loc (HsAppTy t1 t2))
1110 | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2')
1111 <- t2
1112 = do
1113 moveAnnotations lo loc
1114 t1' <- go t1
1115 return (L loc (HsEqTy t1' t2'))
1116 | otherwise
1117 = do
1118 t1' <- go t1
1119 case t1' of
1120 (L lo (HsEqTy tl tr)) -> do
1121 let lr = combineLocs tr t2
1122 moveAnnotations lo loc
1123 return (L loc (HsEqTy tl (L lr (HsAppTy tr t2))))
1124 t -> do
1125 return (L loc (HsAppTy t t2))
1126
1127 go t = return t
1128
1129
1130 -- | Transform tyapps with strict_marks into uses of twiddle
1131 -- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d
1132 splitTildeApps :: [LHsAppType RdrName] -> P [LHsAppType RdrName]
1133 splitTildeApps [] = return []
1134 splitTildeApps (t : rest) = do
1135 rest' <- concatMapM go rest
1136 return (t : rest')
1137 where go (L l (HsAppPrefix
1138 (L loc (HsBangTy
1139 (HsSrcBang NoSourceText NoSrcUnpack SrcLazy)
1140 ty))))
1141 = addAnnotation l AnnTilde tilde_loc >>
1142 return
1143 [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
1144 L l (HsAppPrefix ty)]
1145 -- NOTE: no annotation is attached to an HsAppPrefix, so the
1146 -- surrounding SrcSpan is not critical
1147 where
1148 tilde_loc = srcSpanFirstCharacter loc
1149
1150 go t = return [t]
1151
1152
1153
1154 ---------------------------------------------------------------------------
1155 -- Check for monad comprehensions
1156 --
1157 -- If the flag MonadComprehensions is set, return a `MonadComp' context,
1158 -- otherwise use the usual `ListComp' context
1159
1160 checkMonadComp :: P (HsStmtContext Name)
1161 checkMonadComp = do
1162 pState <- getPState
1163 return $ if extopt LangExt.MonadComprehensions (options pState)
1164 then MonadComp
1165 else ListComp
1166
1167 -- -------------------------------------------------------------------------
1168 -- Checking arrow syntax.
1169
1170 -- We parse arrow syntax as expressions and check for valid syntax below,
1171 -- converting the expression into a pattern at the same time.
1172
1173 checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName)
1174 checkCommand lc = locMap checkCmd lc
1175
1176 locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
1177 locMap f (L l a) = f l a >>= (\b -> return $ L l b)
1178
1179 checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName)
1180 checkCmd _ (HsArrApp e1 e2 ptt haat b) =
1181 return $ HsCmdArrApp e1 e2 ptt haat b
1182 checkCmd _ (HsArrForm e mf args) =
1183 return $ HsCmdArrForm e Prefix mf args
1184 checkCmd _ (HsApp e1 e2) =
1185 checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)
1186 checkCmd _ (HsLam mg) =
1187 checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg')
1188 checkCmd _ (HsPar e) =
1189 checkCommand e >>= (\c -> return $ HsCmdPar c)
1190 checkCmd _ (HsCase e mg) =
1191 checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')
1192 checkCmd _ (HsIf cf ep et ee) = do
1193 pt <- checkCommand et
1194 pe <- checkCommand ee
1195 return $ HsCmdIf cf ep pt pe
1196 checkCmd _ (HsLet lb e) =
1197 checkCommand e >>= (\c -> return $ HsCmdLet lb c)
1198 checkCmd _ (HsDo DoExpr (L l stmts) ty) =
1199 mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty)
1200
1201 checkCmd _ (OpApp eLeft op _fixity eRight) = do
1202 -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
1203 c1 <- checkCommand eLeft
1204 c2 <- checkCommand eRight
1205 let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []
1206 arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []
1207 return $ HsCmdArrForm op Infix Nothing [arg1, arg2]
1208
1209 checkCmd l e = cmdFail l e
1210
1211 checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName)
1212 checkCmdLStmt = locMap checkCmdStmt
1213
1214 checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName)
1215 checkCmdStmt _ (LastStmt e s r) =
1216 checkCommand e >>= (\c -> return $ LastStmt c s r)
1217 checkCmdStmt _ (BindStmt pat e b f t) =
1218 checkCommand e >>= (\c -> return $ BindStmt pat c b f t)
1219 checkCmdStmt _ (BodyStmt e t g ty) =
1220 checkCommand e >>= (\c -> return $ BodyStmt c t g ty)
1221 checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds
1222 checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
1223 ss <- mapM checkCmdLStmt stmts
1224 return $ stmt { recS_stmts = ss }
1225 checkCmdStmt l stmt = cmdStmtFail l stmt
1226
1227 checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName))
1228 checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
1229 ms' <- mapM (locMap $ const convert) ms
1230 return $ mg { mg_alts = L l ms' }
1231 where convert (Match mf pat mty grhss) = do
1232 grhss' <- checkCmdGRHSs grhss
1233 return $ Match mf pat mty grhss'
1234
1235 checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName))
1236 checkCmdGRHSs (GRHSs grhss binds) = do
1237 grhss' <- mapM checkCmdGRHS grhss
1238 return $ GRHSs grhss' binds
1239
1240 checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName))
1241 checkCmdGRHS = locMap $ const convert
1242 where
1243 convert (GRHS stmts e) = do
1244 c <- checkCommand e
1245 -- cmdStmts <- mapM checkCmdLStmt stmts
1246 return $ GRHS {- cmdStmts -} stmts c
1247
1248
1249 cmdFail :: SrcSpan -> HsExpr RdrName -> P a
1250 cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
1251 cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a
1252 cmdStmtFail loc e = parseErrorSDoc loc
1253 (text "Parse error in command statement:" <+> ppr e)
1254
1255 ---------------------------------------------------------------------------
1256 -- Miscellaneous utilities
1257
1258 checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int))
1259 checkPrecP (L l (src,i))
1260 | 0 <= i && i <= maxPrecedence = return (L l (src,i))
1261 | otherwise
1262 = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
1263
1264 mkRecConstrOrUpdate
1265 :: LHsExpr RdrName
1266 -> SrcSpan
1267 -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool)
1268 -> P (HsExpr RdrName)
1269
1270 mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd)
1271 | isRdrDataCon c
1272 = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
1273 mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
1274 | dd = parseErrorSDoc l (text "You cannot use `..' in a record update")
1275 | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
1276
1277 mkRdrRecordUpd :: LHsExpr RdrName -> [LHsRecUpdField RdrName] -> HsExpr RdrName
1278 mkRdrRecordUpd exp flds
1279 = RecordUpd { rupd_expr = exp
1280 , rupd_flds = flds
1281 , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder
1282 , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder }
1283
1284 mkRdrRecordCon :: Located RdrName -> HsRecordBinds RdrName -> HsExpr RdrName
1285 mkRdrRecordCon con flds
1286 = RecordCon { rcon_con_name = con, rcon_flds = flds
1287 , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
1288
1289 mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
1290 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
1291 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
1292
1293 mk_rec_upd_field :: HsRecField RdrName (LHsExpr RdrName) -> HsRecUpdField RdrName
1294 mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun)
1295 = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun
1296
1297 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
1298 -> InlinePragma
1299 -- The (Maybe Activation) is because the user can omit
1300 -- the activation spec (and usually does)
1301 mkInlinePragma src (inl, match_info) mb_act
1302 = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes
1303 , inl_inline = inl
1304 , inl_sat = Nothing
1305 , inl_act = act
1306 , inl_rule = match_info }
1307 where
1308 act = case mb_act of
1309 Just act -> act
1310 Nothing -> -- No phase specified
1311 case inl of
1312 NoInline -> NeverActive
1313 _other -> AlwaysActive
1314
1315 -----------------------------------------------------------------------------
1316 -- utilities for foreign declarations
1317
1318 -- construct a foreign import declaration
1319 --
1320 mkImport :: Located CCallConv
1321 -> Located Safety
1322 -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
1323 -> P (HsDecl RdrName)
1324 mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
1325 case cconv of
1326 L _ CCallConv -> mkCImport
1327 L _ CApiConv -> mkCImport
1328 L _ StdCallConv -> mkCImport
1329 L _ PrimCallConv -> mkOtherImport
1330 L _ JavaScriptCallConv -> mkOtherImport
1331 where
1332 -- Parse a C-like entity string of the following form:
1333 -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"
1334 -- If 'cid' is missing, the function name 'v' is used instead as symbol
1335 -- name (cf section 8.5.1 in Haskell 2010 report).
1336 mkCImport = do
1337 let e = unpackFS entity
1338 case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
1339 Nothing -> parseErrorSDoc loc (text "Malformed entity string")
1340 Just importSpec -> returnSpec importSpec
1341
1342 -- currently, all the other import conventions only support a symbol name in
1343 -- the entity string. If it is missing, we use the function name instead.
1344 mkOtherImport = returnSpec importSpec
1345 where
1346 entity' = if nullFS entity
1347 then mkExtName (unLoc v)
1348 else entity
1349 funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
1350 importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
1351
1352 returnSpec spec = return $ ForD $ ForeignImport
1353 { fd_name = v
1354 , fd_sig_ty = ty
1355 , fd_co = noForeignImportCoercionYet
1356 , fd_fi = spec
1357 }
1358
1359
1360
1361 -- the string "foo" is ambiguous: either a header or a C identifier. The
1362 -- C identifier case comes first in the alternatives below, so we pick
1363 -- that one.
1364 parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
1365 -> Located SourceText
1366 -> Maybe ForeignImport
1367 parseCImport cconv safety nm str sourceText =
1368 listToMaybe $ map fst $ filter (null.snd) $
1369 readP_to_S parse str
1370 where
1371 parse = do
1372 skipSpaces
1373 r <- choice [
1374 string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
1375 string "wrapper" >> return (mk Nothing CWrapper),
1376 do optional (token "static" >> skipSpaces)
1377 ((mk Nothing <$> cimp nm) +++
1378 (do h <- munch1 hdr_char
1379 skipSpaces
1380 mk (Just (Header (SourceText h) (mkFastString h)))
1381 <$> cimp nm))
1382 ]
1383 skipSpaces
1384 return r
1385
1386 token str = do _ <- string str
1387 toks <- look
1388 case toks of
1389 c : _
1390 | id_char c -> pfail
1391 _ -> return ()
1392
1393 mk h n = CImport cconv safety h n sourceText
1394
1395 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
1396 -- pretty much any char (depending on the platform),
1397 -- so just accept any non-space character
1398 id_first_char c = isAlpha c || c == '_'
1399 id_char c = isAlphaNum c || c == '_'
1400
1401 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1402 +++ (do isFun <- case cconv of
1403 L _ CApiConv ->
1404 option True
1405 (do token "value"
1406 skipSpaces
1407 return False)
1408 _ -> return True
1409 cid' <- cid
1410 return (CFunction (StaticTarget NoSourceText cid'
1411 Nothing isFun)))
1412 where
1413 cid = return nm +++
1414 (do c <- satisfy id_first_char
1415 cs <- many (satisfy id_char)
1416 return (mkFastString (c:cs)))
1417
1418
1419 -- construct a foreign export declaration
1420 --
1421 mkExport :: Located CCallConv
1422 -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
1423 -> P (HsDecl RdrName)
1424 mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
1425 = return $ ForD $
1426 ForeignExport { fd_name = v, fd_sig_ty = ty
1427 , fd_co = noForeignExportCoercionYet
1428 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
1429 (L le esrc) }
1430 where
1431 entity' | nullFS entity = mkExtName (unLoc v)
1432 | otherwise = entity
1433
1434 -- Supplying the ext_name in a foreign decl is optional; if it
1435 -- isn't there, the Haskell name is assumed. Note that no transformation
1436 -- of the Haskell name is then performed, so if you foreign export (++),
1437 -- it's external name will be "++". Too bad; it's important because we don't
1438 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1439 --
1440 mkExtName :: RdrName -> CLabelString
1441 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1442
1443 --------------------------------------------------------------------------------
1444 -- Help with module system imports/exports
1445
1446 data ImpExpSubSpec = ImpExpAbs
1447 | ImpExpAll
1448 | ImpExpList [Located ImpExpQcSpec]
1449 | ImpExpAllWith [Located ImpExpQcSpec]
1450
1451 data ImpExpQcSpec = ImpExpQcName (Located RdrName)
1452 | ImpExpQcType (Located RdrName)
1453 | ImpExpQcWildcard
1454
1455 mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE RdrName)
1456 mkModuleImpExp (L l specname) subs =
1457 case subs of
1458 ImpExpAbs
1459 | isVarNameSpace (rdrNameSpace name)
1460 -> return $ IEVar (L l (ieNameFromSpec specname))
1461 | otherwise -> IEThingAbs . L l <$> nameT
1462 ImpExpAll -> IEThingAll . L l <$> nameT
1463 ImpExpList xs ->
1464 (\newName -> IEThingWith (L l newName) NoIEWildcard (wrapped xs) [])
1465 <$> nameT
1466 ImpExpAllWith xs ->
1467 do allowed <- extension patternSynonymsEnabled
1468 if allowed
1469 then
1470 let withs = map unLoc xs
1471 pos = maybe NoIEWildcard IEWildcard
1472 (findIndex isImpExpQcWildcard withs)
1473 ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
1474 in (\newName -> IEThingWith (L l newName) pos ies []) <$> nameT
1475 else parseErrorSDoc l
1476 (text "Illegal export form (use PatternSynonyms to enable)")
1477 where
1478 name = ieNameVal specname
1479 nameT =
1480 if isVarNameSpace (rdrNameSpace name)
1481 then parseErrorSDoc l
1482 (text "Expecting a type constructor but found a variable,"
1483 <+> quotes (ppr name) <> text "."
1484 $$ if isSymOcc $ rdrNameOcc name
1485 then text "If" <+> quotes (ppr name) <+> text "is a type constructor"
1486 <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
1487 else empty)
1488 else return $ ieNameFromSpec specname
1489
1490 ieNameVal (ImpExpQcName ln) = unLoc ln
1491 ieNameVal (ImpExpQcType ln) = unLoc ln
1492 ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard"
1493
1494 ieNameFromSpec (ImpExpQcName ln) = IEName ln
1495 ieNameFromSpec (ImpExpQcType ln) = IEType ln
1496 ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
1497
1498 wrapped = map (\(L l x) -> L l (ieNameFromSpec x))
1499
1500 mkTypeImpExp :: Located RdrName -- TcCls or Var name space
1501 -> P (Located RdrName)
1502 mkTypeImpExp name =
1503 do allowed <- extension explicitNamespacesEnabled
1504 if allowed
1505 then return (fmap (`setRdrNameSpace` tcClsName) name)
1506 else parseErrorSDoc (getLoc name)
1507 (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
1508
1509 checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName])
1510 checkImportSpec ie@(L _ specs) =
1511 case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of
1512 [] -> return ie
1513 (l:_) -> importSpecError l
1514 where
1515 importSpecError l =
1516 parseErrorSDoc l
1517 (text "Illegal import form, this syntax can only be used to bundle"
1518 $+$ text "pattern synonyms with types in module exports.")
1519
1520 -- In the correct order
1521 mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
1522 mkImpExpSubSpec [] = return ([], ImpExpList [])
1523 mkImpExpSubSpec [L _ ImpExpQcWildcard] =
1524 return ([], ImpExpAll)
1525 mkImpExpSubSpec xs =
1526 if (any (isImpExpQcWildcard . unLoc) xs)
1527 then return $ ([], ImpExpAllWith xs)
1528 else return $ ([], ImpExpList xs)
1529
1530 isImpExpQcWildcard :: ImpExpQcSpec -> Bool
1531 isImpExpQcWildcard ImpExpQcWildcard = True
1532 isImpExpQcWildcard _ = False
1533
1534 -----------------------------------------------------------------------------
1535 -- Misc utils
1536
1537 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1538 parseErrorSDoc span s = failSpanMsgP span s
1539
1540 data SumOrTuple
1541 = Sum ConTag Arity (LHsExpr RdrName)
1542 | Tuple [LHsTupArg RdrName]
1543
1544 mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr RdrName)
1545
1546 -- Tuple
1547 mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity)
1548
1549 -- Sum
1550 mkSumOrTuple Unboxed _ (Sum alt arity e) =
1551 return (ExplicitSum alt arity e PlaceHolder)
1552 mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
1553 parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
1554 where
1555 ppr_boxed_sum :: ConTag -> Arity -> HsExpr RdrName -> SDoc
1556 ppr_boxed_sum alt arity e =
1557 text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"
1558
1559 ppr_bars n = hsep (replicate n (Outputable.char '|'))