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