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