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