9917d960f83ebc2b1ad690d691d0f52393aca0bb
[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 mkInlinePragma,
23 mkPatSynMatchGroup,
24 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
25 mkTyClD, mkInstD,
26 mkRdrRecordCon, mkRdrRecordUpd,
27 setRdrNameSpace,
28 filterCTuple,
29
30 cvBindGroup,
31 cvBindsAndSigs,
32 cvTopDecls,
33 placeHolderPunRhs,
34
35 -- Stuff to do with Foreign declarations
36 mkImport,
37 parseCImport,
38 mkExport,
39 mkExtName, -- RdrName -> CLabelString
40 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
41 mkConDeclH98,
42 mkATDefault,
43
44 -- Bunch of functions in the parser monad for
45 -- checking and constructing values
46 checkBlockArguments,
47 checkPrecP, -- Int -> P Int
48 checkContext, -- HsType -> P HsContext
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 LRuleTyTmVar, RuleTyTmVar(..),
58 mkRuleBndrs, mkRuleTyVarBndrs,
59 checkRuleTyVarBndrNames,
60 checkRecordSyntax,
61 checkEmptyGADTs,
62 parseErrorSDoc, hintBangPat,
63 TyEl(..), mergeOps, mergeDataCon,
64
65 -- Help with processing exports
66 ImpExpSubSpec(..),
67 ImpExpQcSpec(..),
68 mkModuleImpExp,
69 mkTypeImpExp,
70 mkImpExpSubSpec,
71 checkImportSpec,
72
73 -- Warnings and errors
74 warnStarIsType,
75 failOpFewArgs,
76
77 SumOrTuple (..), mkSumOrTuple
78
79 ) where
80
81 import GhcPrelude
82 import HsSyn -- Lots of it
83 import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
84 import DataCon ( DataCon, dataConTyCon )
85 import ConLike ( ConLike(..) )
86 import CoAxiom ( Role, fsFromRole )
87 import RdrName
88 import Name
89 import BasicTypes
90 import TcEvidence ( idHsWrapper )
91 import Lexer
92 import Lexeme ( isLexCon )
93 import Type ( TyThing(..), funTyCon )
94 import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon,
95 nilDataConName, nilDataConKey,
96 listTyConName, listTyConKey, eqTyCon_RDR,
97 tupleTyConName, cTupleTyConNameArity_maybe )
98 import ForeignCall
99 import PrelNames ( forall_tv_RDR, allNameStrings )
100 import SrcLoc
101 import Unique ( hasKey )
102 import OrdList ( OrdList, fromOL )
103 import Bag ( emptyBag, consBag )
104 import Outputable
105 import FastString
106 import Maybes
107 import Util
108 import ApiAnnotation
109 import HsExtension ( noExt )
110 import Data.List
111 import qualified GHC.LanguageExtensions as LangExt
112 import DynFlags ( WarningFlag(..) )
113
114 import Control.Monad
115 import Text.ParserCombinators.ReadP as ReadP
116 import Data.Char
117
118 import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
119
120 #include "HsVersions.h"
121
122
123 {- **********************************************************************
124
125 Construction functions for Rdr stuff
126
127 ********************************************************************* -}
128
129 -- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and
130 -- datacon by deriving them from the name of the class. We fill in the names
131 -- for the tycon and datacon corresponding to the class, by deriving them
132 -- from the name of the class itself. This saves recording the names in the
133 -- interface file (which would be equally good).
134
135 -- Similarly for mkConDecl, mkClassOpSig and default-method names.
136
137 -- *** See Note [The Naming story] in HsDecls ****
138
139 mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
140 mkTyClD (L loc d) = L loc (TyClD noExt d)
141
142 mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
143 mkInstD (L loc d) = L loc (InstD noExt d)
144
145 mkClassDecl :: SrcSpan
146 -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
147 -> Located (a,[LHsFunDep GhcPs])
148 -> OrdList (LHsDecl GhcPs)
149 -> P (LTyClDecl GhcPs)
150
151 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
152 = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
153 ; let cxt = fromMaybe (noLoc []) mcxt
154 ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
155 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
156 ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
157 ; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts
158 ; sequence_ anns
159 ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
160 , tcdLName = cls, tcdTyVars = tyvars
161 , tcdFixity = fixity
162 , tcdFDs = snd (unLoc fds)
163 , tcdSigs = mkClassOpSigs sigs
164 , tcdMeths = binds
165 , tcdATs = ats, tcdATDefs = at_defs
166 , tcdDocs = docs })) }
167
168 mkATDefault :: LTyFamInstDecl GhcPs
169 -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ())
170 -- ^ Take a type-family instance declaration and turn it into
171 -- a type-family default equation for a class declaration.
172 -- We parse things as the former and use this function to convert to the latter
173 --
174 -- We use the Either monad because this also called from "Convert".
175 --
176 -- The @P ()@ we return corresponds represents an action which will add
177 -- some necessary paren annotations to the parsing context. Naturally, this
178 -- is not something that the "Convert" use cares about.
179 mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
180 | FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats
181 , feqn_fixity = fixity, feqn_rhs = rhs } <- e
182 = do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats
183 ; let f = L loc (FamEqn { feqn_ext = noExt
184 , feqn_tycon = tc
185 , feqn_bndrs = ASSERT( isNothing bndrs )
186 Nothing
187 , feqn_pats = tvs
188 , feqn_fixity = fixity
189 , feqn_rhs = rhs })
190 ; pure (f, anns) }
191 mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
192 mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
193
194 mkTyData :: SrcSpan
195 -> NewOrData
196 -> Maybe (Located CType)
197 -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
198 -> Maybe (LHsKind GhcPs)
199 -> [LConDecl GhcPs]
200 -> HsDeriving GhcPs
201 -> P (LTyClDecl GhcPs)
202 mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
203 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
204 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
205 ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
206 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
207 ; return (L loc (DataDecl { tcdDExt = noExt,
208 tcdLName = tc, tcdTyVars = tyvars,
209 tcdFixity = fixity,
210 tcdDataDefn = defn })) }
211
212 mkDataDefn :: NewOrData
213 -> Maybe (Located CType)
214 -> Maybe (LHsContext GhcPs)
215 -> Maybe (LHsKind GhcPs)
216 -> [LConDecl GhcPs]
217 -> HsDeriving GhcPs
218 -> P (HsDataDefn GhcPs)
219 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
220 = do { checkDatatypeContext mcxt
221 ; let cxt = fromMaybe (noLoc []) mcxt
222 ; return (HsDataDefn { dd_ext = noExt
223 , dd_ND = new_or_data, dd_cType = cType
224 , dd_ctxt = cxt
225 , dd_cons = data_cons
226 , dd_kindSig = ksig
227 , dd_derivs = maybe_deriv }) }
228
229
230 mkTySynonym :: SrcSpan
231 -> LHsType GhcPs -- LHS
232 -> LHsType GhcPs -- RHS
233 -> P (LTyClDecl GhcPs)
234 mkTySynonym loc lhs rhs
235 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
236 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
237 ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
238 ; return (L loc (SynDecl { tcdSExt = noExt
239 , tcdLName = tc, tcdTyVars = tyvars
240 , tcdFixity = fixity
241 , tcdRhs = rhs })) }
242
243 mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
244 -> LHsType GhcPs
245 -> LHsType GhcPs
246 -> P (TyFamInstEqn GhcPs,[AddAnn])
247 mkTyFamInstEqn bndrs lhs rhs
248 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
249 ; return (mkHsImplicitBndrs
250 (FamEqn { feqn_ext = noExt
251 , feqn_tycon = tc
252 , feqn_bndrs = bndrs
253 , feqn_pats = tparams
254 , feqn_fixity = fixity
255 , feqn_rhs = rhs }),
256 ann) }
257
258 mkDataFamInst :: SrcSpan
259 -> NewOrData
260 -> Maybe (Located CType)
261 -> Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs)
262 -> Maybe (LHsKind GhcPs)
263 -> [LConDecl GhcPs]
264 -> HsDeriving GhcPs
265 -> P (LInstDecl GhcPs)
266 mkDataFamInst loc new_or_data cType (L _ (mcxt, bndrs, tycl_hdr)) ksig data_cons maybe_deriv
267 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
268 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
269 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
270 ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
271 (FamEqn { feqn_ext = noExt
272 , feqn_tycon = tc
273 , feqn_bndrs = bndrs
274 , feqn_pats = tparams
275 , feqn_fixity = fixity
276 , feqn_rhs = defn }))))) }
277
278 mkTyFamInst :: SrcSpan
279 -> TyFamInstEqn GhcPs
280 -> P (LInstDecl GhcPs)
281 mkTyFamInst loc eqn
282 = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn)))
283
284 mkFamDecl :: SrcSpan
285 -> FamilyInfo GhcPs
286 -> LHsType GhcPs -- LHS
287 -> Located (FamilyResultSig GhcPs) -- Optional result signature
288 -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation
289 -> P (LTyClDecl GhcPs)
290 mkFamDecl loc info lhs ksig injAnn
291 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
292 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
293 ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
294 ; return (L loc (FamDecl noExt (FamilyDecl
295 { fdExt = noExt
296 , fdInfo = info, fdLName = tc
297 , fdTyVars = tyvars
298 , fdFixity = fixity
299 , fdResultSig = ksig
300 , fdInjectivityAnn = injAnn }))) }
301 where
302 equals_or_where = case info of
303 DataFamily -> empty
304 OpenTypeFamily -> empty
305 ClosedTypeFamily {} -> whereDots
306
307 mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
308 -- If the user wrote
309 -- [pads| ... ] then return a QuasiQuoteD
310 -- $(e) then return a SpliceD
311 -- but if she wrote, say,
312 -- f x then behave as if she'd written $(f x)
313 -- ie a SpliceD
314 --
315 -- Typed splices are not allowed at the top level, thus we do not represent them
316 -- as spliced declaration. See #10945
317 mkSpliceDecl lexpr@(L loc expr)
318 | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
319 = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
320
321 | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
322 = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
323
324 | otherwise
325 = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr))
326 ImplicitSplice)
327
328 mkRoleAnnotDecl :: SrcSpan
329 -> Located RdrName -- type being annotated
330 -> [Located (Maybe FastString)] -- roles
331 -> P (LRoleAnnotDecl GhcPs)
332 mkRoleAnnotDecl loc tycon roles
333 = do { roles' <- mapM parse_role roles
334 ; return $ L loc $ RoleAnnotDecl noExt tycon roles' }
335 where
336 role_data_type = dataTypeOf (undefined :: Role)
337 all_roles = map fromConstr $ dataTypeConstrs role_data_type
338 possible_roles = [(fsFromRole role, role) | role <- all_roles]
339
340 parse_role (L loc_role Nothing) = return $ L loc_role Nothing
341 parse_role (L loc_role (Just role))
342 = case lookup role possible_roles of
343 Just found_role -> return $ L loc_role $ Just found_role
344 Nothing ->
345 let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
346 parseErrorSDoc loc_role
347 (text "Illegal role name" <+> quotes (ppr role) $$
348 suggestions nearby)
349
350 suggestions [] = empty
351 suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r)
352 -- will this last case ever happen??
353 suggestions list = hang (text "Perhaps you meant one of these:")
354 2 (pprWithCommas (quotes . ppr) list)
355
356 {- **********************************************************************
357
358 #cvBinds-etc# Converting to @HsBinds@, etc.
359
360 ********************************************************************* -}
361
362 -- | Function definitions are restructured here. Each is assumed to be recursive
363 -- initially, and non recursive definitions are discovered by the dependency
364 -- analyser.
365
366
367 -- | Groups together bindings for a single function
368 cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
369 cvTopDecls decls = go (fromOL decls)
370 where
371 go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
372 go [] = []
373 go (L l (ValD x b) : ds) = L l' (ValD x b') : go ds'
374 where (L l' b', ds') = getMonoBind (L l b) ds
375 go (d : ds) = d : go ds
376
377 -- Declaration list may only contain value bindings and signatures.
378 cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
379 cvBindGroup binding
380 = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
381 ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
382 return $ ValBinds noExt mbs sigs }
383
384 cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
385 -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
386 , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
387 -- Input decls contain just value bindings and signatures
388 -- and in case of class or instance declarations also
389 -- associated type declarations. They might also contain Haddock comments.
390 cvBindsAndSigs fb = go (fromOL fb)
391 where
392 go [] = return (emptyBag, [], [], [], [], [])
393 go (L l (ValD _ b) : ds)
394 = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
395 ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
396 where
397 (b', ds') = getMonoBind (L l b) ds
398 go (L l decl : ds)
399 = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
400 ; case decl of
401 SigD _ s
402 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
403 TyClD _ (FamDecl _ t)
404 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
405 InstD _ (TyFamInstD { tfid_inst = tfi })
406 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
407 InstD _ (DataFamInstD { dfid_inst = dfi })
408 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
409 DocD _ d
410 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
411 SpliceD _ d
412 -> parseErrorSDoc l $
413 hang (text "Declaration splices are allowed only" <+>
414 text "at the top level:")
415 2 (ppr d)
416 _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
417
418 -----------------------------------------------------------------------------
419 -- Group function bindings into equation groups
420
421 getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
422 -> (LHsBind GhcPs, [LHsDecl GhcPs])
423 -- Suppose (b',ds') = getMonoBind b ds
424 -- ds is a list of parsed bindings
425 -- b is a MonoBinds that has just been read off the front
426
427 -- Then b' is the result of grouping more equations from ds that
428 -- belong with b into a single MonoBinds, and ds' is the depleted
429 -- list of parsed bindings.
430 --
431 -- All Haddock comments between equations inside the group are
432 -- discarded.
433 --
434 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
435
436 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
437 fun_matches
438 = MG { mg_alts = L _ mtchs1 } })) binds
439 | has_args mtchs1
440 = go mtchs1 loc1 binds []
441 where
442 go mtchs loc
443 (L loc2 (ValD _ (FunBind { fun_id = L _ f2,
444 fun_matches
445 = MG { mg_alts = L _ mtchs2 } })) : binds) _
446 | f1 == f2 = go (mtchs2 ++ mtchs)
447 (combineSrcSpans loc loc2) binds []
448 go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
449 = let doc_decls' = doc_decl : doc_decls
450 in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
451 go mtchs loc binds doc_decls
452 = ( L loc (makeFunBind fun_id1 (reverse mtchs))
453 , (reverse doc_decls) ++ binds)
454 -- Reverse the final matches, to get it back in the right order
455 -- Do the same thing with the trailing doc comments
456
457 getMonoBind bind binds = (bind, binds)
458
459 has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
460 has_args [] = panic "RdrHsSyn:has_args"
461 has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
462 -- Don't group together FunBinds if they have
463 -- no arguments. This is necessary now that variable bindings
464 -- with no arguments are now treated as FunBinds rather
465 -- than pattern bindings (tests/rename/should_fail/rnfail002).
466 has_args ((L _ (XMatch _)) : _) = panic "has_args"
467
468 {- **********************************************************************
469
470 #PrefixToHS-utils# Utilities for conversion
471
472 ********************************************************************* -}
473
474 {- Note [Parsing data constructors is hard]
475 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
476
477 The problem with parsing data constructors is that they look a lot like types.
478 Compare:
479
480 (s1) data T = C t1 t2
481 (s2) type T = C t1 t2
482
483 Syntactically, there's little difference between these declarations, except in
484 (s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.
485
486 This similarity would pose no problem if we knew ahead of time if we are
487 parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple
488 (but wrong!) rule comes to mind: in 'data' declarations assume we are parsing
489 data constructors, and in other contexts (e.g. 'type' declarations) assume we
490 are parsing type constructors.
491
492 This simple rule does not work because of two problematic cases:
493
494 (p1) data T = C t1 t2 :+ t3
495 (p2) data T = C t1 t2 => t3
496
497 In (p1) we encounter (:+) and it turns out we are parsing an infix data
498 declaration, so (C t1 t2) is a type and 'C' is a type constructor.
499 In (p2) we encounter (=>) and it turns out we are parsing an existential
500 context, so (C t1 t2) is a constraint and 'C' is a type constructor.
501
502 As the result, in order to determine whether (C t1 t2) declares a data
503 constructor, a type, or a context, we would need unlimited lookahead which
504 'happy' is not so happy with.
505
506 To further complicate matters, the interpretation of (!) and (~) is different
507 in constructors and types:
508
509 (b1) type T = C ! D
510 (b2) data T = C ! D
511 (b3) data T = C ! D => E
512
513 In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At
514 the same time, in (b2) it is a strictness annotation: 'C' is a data constructor
515 with a single strict argument 'D'. For the programmer, these cases are usually
516 easy to tell apart due to whitespace conventions:
517
518 (b2) data T = C !D -- no space after the bang hints that
519 -- it is a strictness annotation
520
521 For the parser, on the other hand, this whitespace does not matter. We cannot
522 tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited
523 lookahead.
524
525 The solution that accounts for all of these issues is to initially parse data
526 declarations and types as a reversed list of TyEl:
527
528 data TyEl = TyElOpr RdrName
529 | TyElOpd (HsType GhcPs)
530 | TyElBang | TyElTilde
531 | ...
532
533 For example, both occurences of (C ! D) in the following example are parsed
534 into equal lists of TyEl:
535
536 data T = C ! D => C ! D results in [ TyElOpd (HsTyVar "D")
537 , TyElBang
538 , TyElOpd (HsTyVar "C") ]
539
540 Note that elements are in reverse order. Also, 'C' is parsed as a type
541 constructor (HsTyVar) even when it is a data constructor. We fix this in
542 `tyConToDataCon`.
543
544 By the time the list of TyEl is assembled, we have looked ahead enough to
545 decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for
546 data constructors). These functions are where the actual job of parsing is
547 done.
548
549 -}
550
551 -- | Reinterpret a type constructor, including type operators, as a data
552 -- constructor.
553 -- See Note [Parsing data constructors is hard]
554 tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
555 tyConToDataCon loc tc
556 | isTcOcc occ || isDataOcc occ
557 , isLexCon (occNameFS occ)
558 = return (L loc (setRdrNameSpace tc srcDataName))
559
560 | otherwise
561 = Left (loc, msg $$ extra)
562 where
563 occ = rdrNameOcc tc
564
565 msg = text "Not a data constructor:" <+> quotes (ppr tc)
566 extra | tc == forall_tv_RDR
567 = text "Perhaps you intended to use ExistentialQuantification"
568 | otherwise = empty
569
570 mkPatSynMatchGroup :: Located RdrName
571 -> Located (OrdList (LHsDecl GhcPs))
572 -> P (MatchGroup GhcPs (LHsExpr GhcPs))
573 mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
574 do { matches <- mapM fromDecl (fromOL decls)
575 ; when (null matches) (wrongNumberErr loc)
576 ; return $ mkMatchGroup FromSource matches }
577 where
578 fromDecl (L loc decl@(ValD _ (PatBind _
579 pat@(L _ (ConPatIn ln@(L _ name) details))
580 rhs _))) =
581 do { unless (name == patsyn_name) $
582 wrongNameBindingErr loc decl
583 ; match <- case details of
584 PrefixCon pats -> return $ Match { m_ext = noExt
585 , m_ctxt = ctxt, m_pats = pats
586 , m_grhss = rhs }
587 where
588 ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict }
589
590 InfixCon p1 p2 -> return $ Match { m_ext = noExt
591 , m_ctxt = ctxt
592 , m_pats = [p1, p2]
593 , m_grhss = rhs }
594 where
595 ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }
596
597 RecCon{} -> recordPatSynErr loc pat
598 ; return $ L loc match }
599 fromDecl (L loc decl) = extraDeclErr loc decl
600
601 extraDeclErr loc decl =
602 parseErrorSDoc loc $
603 text "pattern synonym 'where' clause must contain a single binding:" $$
604 ppr decl
605
606 wrongNameBindingErr loc decl =
607 parseErrorSDoc loc $
608 text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
609 quotes (ppr patsyn_name) $$ ppr decl
610
611 wrongNumberErr loc =
612 parseErrorSDoc loc $
613 text "pattern synonym 'where' clause cannot be empty" $$
614 text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
615
616 recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
617 recordPatSynErr loc pat =
618 parseErrorSDoc loc $
619 text "record syntax not supported for pattern synonym declarations:" $$
620 ppr pat
621
622 mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
623 -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
624 -> ConDecl GhcPs
625
626 mkConDeclH98 name mb_forall mb_cxt args
627 = ConDeclH98 { con_ext = noExt
628 , con_name = name
629 , con_forall = noLoc $ isJust mb_forall
630 , con_ex_tvs = mb_forall `orElse` []
631 , con_mb_cxt = mb_cxt
632 , con_args = args'
633 , con_doc = Nothing }
634 where
635 args' = nudgeHsSrcBangs args
636
637 mkGadtDecl :: [Located RdrName]
638 -> LHsType GhcPs -- Always a HsForAllTy
639 -> (ConDecl GhcPs, [AddAnn])
640 mkGadtDecl names ty
641 = (ConDeclGADT { con_g_ext = noExt
642 , con_names = names
643 , con_forall = L l $ isLHsForAllTy ty'
644 , con_qvars = mkHsQTvs tvs
645 , con_mb_cxt = mcxt
646 , con_args = args'
647 , con_res_ty = res_ty
648 , con_doc = Nothing }
649 , anns1 ++ anns2)
650 where
651 (ty'@(L l _),anns1) = peel_parens ty []
652 (tvs, rho) = splitLHsForAllTy ty'
653 (mcxt, tau, anns2) = split_rho rho []
654
655 split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
656 = (Just cxt, tau, ann)
657 split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
658 split_rho tau ann = (Nothing, tau, ann)
659
660 (args, res_ty) = split_tau tau
661 args' = nudgeHsSrcBangs args
662
663 -- See Note [GADT abstract syntax] in HsDecls
664 split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
665 = (RecCon (L loc rf), res_ty)
666 split_tau tau = (PrefixCon [], tau)
667
668 peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
669 (ann++mkParensApiAnn l)
670 peel_parens ty ann = (ty, ann)
671
672 nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
673 -- ^ This function ensures that fields with strictness or packedness
674 -- annotations put these annotations on an outer 'HsBangTy'.
675 --
676 -- The problem is that in the parser, strictness and packedness annotations
677 -- bind more tightly that docstrings. However, the expectation downstream of
678 -- the parser (by functions such as 'getBangType' and 'getBangStrictness')
679 -- is that docstrings bind more tightly so that 'HsBangTy' may end up as the
680 -- top-level type.
681 --
682 -- See #15206
683 nudgeHsSrcBangs details
684 = case details of
685 PrefixCon as -> PrefixCon (map go as)
686 RecCon r -> RecCon r
687 InfixCon a1 a2 -> InfixCon (go a1) (go a2)
688 where
689 go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) =
690 L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
691 go lty = lty
692
693
694 setRdrNameSpace :: RdrName -> NameSpace -> RdrName
695 -- ^ This rather gruesome function is used mainly by the parser.
696 -- When parsing:
697 --
698 -- > data T a = T | T1 Int
699 --
700 -- we parse the data constructors as /types/ because of parser ambiguities,
701 -- so then we need to change the /type constr/ to a /data constr/
702 --
703 -- The exact-name case /can/ occur when parsing:
704 --
705 -- > data [] a = [] | a : [a]
706 --
707 -- For the exact-name case we return an original name.
708 setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
709 setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
710 setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
711 setRdrNameSpace (Exact n) ns
712 | Just thing <- wiredInNameTyThing_maybe n
713 = setWiredInNameSpace thing ns
714 -- Preserve Exact Names for wired-in things,
715 -- notably tuples and lists
716
717 | isExternalName n
718 = Orig (nameModule n) occ
719
720 | otherwise -- This can happen when quoting and then
721 -- splicing a fixity declaration for a type
722 = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
723 where
724 occ = setOccNameSpace ns (nameOccName n)
725
726 setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
727 setWiredInNameSpace (ATyCon tc) ns
728 | isDataConNameSpace ns
729 = ty_con_data_con tc
730 | isTcClsNameSpace ns
731 = Exact (getName tc) -- No-op
732
733 setWiredInNameSpace (AConLike (RealDataCon dc)) ns
734 | isTcClsNameSpace ns
735 = data_con_ty_con dc
736 | isDataConNameSpace ns
737 = Exact (getName dc) -- No-op
738
739 setWiredInNameSpace thing ns
740 = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)
741
742 ty_con_data_con :: TyCon -> RdrName
743 ty_con_data_con tc
744 | isTupleTyCon tc
745 , Just dc <- tyConSingleDataCon_maybe tc
746 = Exact (getName dc)
747
748 | tc `hasKey` listTyConKey
749 = Exact nilDataConName
750
751 | otherwise -- See Note [setRdrNameSpace for wired-in names]
752 = Unqual (setOccNameSpace srcDataName (getOccName tc))
753
754 data_con_ty_con :: DataCon -> RdrName
755 data_con_ty_con dc
756 | let tc = dataConTyCon dc
757 , isTupleTyCon tc
758 = Exact (getName tc)
759
760 | dc `hasKey` nilDataConKey
761 = Exact listTyConName
762
763 | otherwise -- See Note [setRdrNameSpace for wired-in names]
764 = Unqual (setOccNameSpace tcClsName (getOccName dc))
765
766 -- | Replaces constraint tuple names with corresponding boxed ones.
767 filterCTuple :: RdrName -> RdrName
768 filterCTuple (Exact n)
769 | Just arity <- cTupleTyConNameArity_maybe n
770 = Exact $ tupleTyConName BoxedTuple arity
771 filterCTuple rdr = rdr
772
773
774 {- Note [setRdrNameSpace for wired-in names]
775 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
776 In GHC.Types, which declares (:), we have
777 infixr 5 :
778 The ambiguity about which ":" is meant is resolved by parsing it as a
779 data constructor, but then using dataTcOccs to try the type constructor too;
780 and that in turn calls setRdrNameSpace to change the name-space of ":" to
781 tcClsName. There isn't a corresponding ":" type constructor, but it's painful
782 to make setRdrNameSpace partial, so we just make an Unqual name instead. It
783 really doesn't matter!
784 -}
785
786 checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
787 -> P (LHsQTyVars GhcPs)
788 -- Same as checkTyVars, but in the P monad
789 checkTyVarsP pp_what equals_or_where tc tparms
790 = do { let checkedTvs = checkTyVars pp_what equals_or_where tc tparms
791 ; (tvs, anns) <- eitherToP checkedTvs
792 ; anns
793 ; pure tvs }
794
795 eitherToP :: Either (SrcSpan, SDoc) a -> P a
796 -- Adapts the Either monad to the P monad
797 eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
798 eitherToP (Right thing) = return thing
799
800 checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
801 -> Either (SrcSpan, SDoc)
802 ( LHsQTyVars GhcPs -- the synthesized type variables
803 , P () ) -- action which adds annotations
804 -- ^ Check whether the given list of type parameters are all type variables
805 -- (possibly with a kind signature).
806 -- We use the Either monad because it's also called (via 'mkATDefault') from
807 -- "Convert".
808 checkTyVars pp_what equals_or_where tc tparms
809 = do { (tvs, anns) <- fmap unzip $ mapM (chkParens []) tparms
810 ; return (mkHsQTvs tvs, sequence_ anns) }
811 where
812 -- Keep around an action for adjusting the annotations of extra parens
813 chkParens :: [AddAnn] -> LHsType GhcPs
814 -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ())
815 chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty
816 chkParens acc ty = case chk ty of
817 Left err -> Left err
818 Right tv@(L l _) -> Right (tv, addAnnsAt l (reverse acc))
819
820 -- Check that the name space is correct!
821 chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
822 | isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k))
823 chk (L l (HsTyVar _ _ (L ltv tv)))
824 | isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv)))
825 chk t@(L loc _)
826 = Left (loc,
827 vcat [ text "Unexpected type" <+> quotes (ppr t)
828 , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes tc'
829 , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form"))
830 , nest 2 (pp_what <+> tc'
831 <+> hsep (map text (takeList tparms allNameStrings))
832 <+> equals_or_where) ] ])
833
834 -- Avoid printing a constraint tuple in the error message. Print
835 -- a plain old tuple instead (since that's what the user probably
836 -- wrote). See #14907
837 tc' = ppr $ fmap filterCTuple tc
838
839
840
841 whereDots, equalsDots :: SDoc
842 -- Second argument to checkTyVars
843 whereDots = text "where ..."
844 equalsDots = text "= ..."
845
846 checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
847 checkDatatypeContext Nothing = return ()
848 checkDatatypeContext (Just (L loc c))
849 = do allowed <- extension datatypeContextsEnabled
850 unless allowed $
851 parseErrorSDoc loc
852 (text "Illegal datatype context (use DatatypeContexts):" <+>
853 pprHsContext c)
854
855 type LRuleTyTmVar = Located RuleTyTmVar
856 data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
857 -- ^ Essentially a wrapper for a @RuleBndr GhcPs@
858
859 -- turns RuleTyTmVars into RuleBnrs - this is straightforward
860 mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
861 mkRuleBndrs = fmap (fmap cvt_one)
862 where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExt v
863 cvt_one (RuleTyTmVar v (Just sig)) = RuleBndrSig noExt v (mkLHsSigWcType sig)
864
865 -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
866 mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
867 mkRuleTyVarBndrs = fmap (fmap cvt_one)
868 where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExt (fmap tm_to_ty v)
869 cvt_one (RuleTyTmVar v (Just sig)) = KindedTyVar noExt (fmap tm_to_ty v) sig
870 -- takes something in namespace 'varName' to something in namespace 'tvName'
871 tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)
872 tm_to_ty _ = panic "mkRuleTyVarBndrs"
873
874 -- See note [Parsing explicit foralls in Rules] in Parser.y
875 checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
876 checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
877 where check (L loc (Unqual occ)) = do
878 when ((occNameString occ ==) `any` ["forall","family","role"])
879 (parseErrorSDoc loc (text $ "parse error on input " ++ occNameString occ))
880 check _ = panic "checkRuleTyVarBndrNames"
881
882 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
883 checkRecordSyntax lr@(L loc r)
884 = do allowed <- extension traditionalRecordSyntaxEnabled
885 if allowed
886 then return lr
887 else parseErrorSDoc loc
888 (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
889 ppr r)
890
891 -- | Check if the gadt_constrlist is empty. Only raise parse error for
892 -- `data T where` to avoid affecting existing error message, see #8258.
893 checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
894 -> P (Located ([AddAnn], [LConDecl GhcPs]))
895 checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration.
896 = do opts <- fmap options getPState
897 if LangExt.GADTSyntax `extopt` opts -- GADTs implies GADTSyntax
898 then return gadts
899 else parseErrorSDoc span $ vcat
900 [ text "Illegal keyword 'where' in data declaration"
901 , text "Perhaps you intended to use GADTs or a similar language"
902 , text "extension to enable syntax: data T where"
903 ]
904 checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration.
905
906 checkTyClHdr :: Bool -- True <=> class header
907 -- False <=> type header
908 -> LHsType GhcPs
909 -> P (Located RdrName, -- the head symbol (type or class name)
910 [LHsType GhcPs], -- parameters of head symbol
911 LexicalFixity, -- the declaration is in infix format
912 [AddAnn]) -- API Annotation for HsParTy when stripping parens
913 -- Well-formedness check and decomposition of type and class heads.
914 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
915 -- Int :*: Bool into (:*:, [Int, Bool])
916 -- returning the pieces
917 checkTyClHdr is_cls ty
918 = goL ty [] [] Prefix
919 where
920 goL (L l ty) acc ann fix = go l ty acc ann fix
921
922 -- workaround to define '*' despite StarIsType
923 go _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
924 = do { warnStarBndr l
925 ; let name = mkOccName tcClsName (if isUni then "★" else "*")
926 ; return (L l (Unqual name), acc, fix, ann) }
927
928 go l (HsTyVar _ _ (L _ tc)) acc ann fix
929 | isRdrTc tc = return (L l tc, acc, fix, ann)
930 go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
931 | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann)
932 go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
933 go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
934
935 go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
936 = return (L l (nameRdrName tup_name), ts, fix, ann)
937 where
938 arity = length ts
939 tup_name | is_cls = cTupleTyConName arity
940 | otherwise = getName (tupleTyCon Boxed arity)
941 -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?)
942 go l _ _ _ _
943 = parseErrorSDoc l (text "Malformed head of type or class declaration:"
944 <+> ppr ty)
945
946 -- | Yield a parse error if we have a function applied directly to a do block
947 -- etc. and BlockArguments is not enabled.
948 checkBlockArguments :: LHsExpr GhcPs -> P ()
949 checkBlockArguments expr = case unLoc expr of
950 HsDo _ DoExpr _ -> check "do block"
951 HsDo _ MDoExpr _ -> check "mdo block"
952 HsLam {} -> check "lambda expression"
953 HsCase {} -> check "case expression"
954 HsLamCase {} -> check "lambda-case expression"
955 HsLet {} -> check "let expression"
956 HsIf {} -> check "if expression"
957 HsProc {} -> check "proc expression"
958 _ -> return ()
959 where
960 check element = do
961 pState <- getPState
962 unless (extopt LangExt.BlockArguments (options pState)) $
963 parseErrorSDoc (getLoc expr) $
964 text "Unexpected " <> text element <> text " in function application:"
965 $$ nest 4 (ppr expr)
966 $$ text "You could write it with parentheses"
967 $$ text "Or perhaps you meant to enable BlockArguments?"
968
969 -- | Validate the context constraints and break up a context into a list
970 -- of predicates.
971 --
972 -- @
973 -- (Eq a, Ord b) --> [Eq a, Ord b]
974 -- Eq a --> [Eq a]
975 -- (Eq a) --> [Eq a]
976 -- (((Eq a))) --> [Eq a]
977 -- @
978 checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
979 checkContext (L l orig_t)
980 = check [] (L l orig_t)
981 where
982 check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
983 -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
984 -- be used as context constraints.
985 = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
986
987 check anns (L lp1 (HsParTy _ ty))
988 -- to be sure HsParTy doesn't get into the way
989 = check anns' ty
990 where anns' = if l == lp1 then anns
991 else (anns ++ mkParensApiAnn lp1)
992
993 -- no need for anns, returning original
994 check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t])
995
996 msg = text "data constructor context"
997
998 -- | Check recursively if there are any 'HsDocTy's in the given type.
999 -- This only works on a subset of types produced by 'btype_no_ops'
1000 checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
1001 checkNoDocs msg ty = go ty
1002 where
1003 go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
1004 go (L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
1005 [ text "Unexpected haddock", quotes (ppr ds)
1006 , text "on", msg, quotes (ppr t) ]
1007 go _ = pure ()
1008
1009 -- -------------------------------------------------------------------------
1010 -- Checking Patterns.
1011
1012 -- We parse patterns as expressions and check for valid patterns below,
1013 -- converting the expression into a pattern at the same time.
1014
1015 checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
1016 checkPattern msg e = checkLPat msg e
1017
1018 checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
1019 checkPatterns msg es = mapM (checkPattern msg) es
1020
1021 checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
1022 checkLPat msg e@(L l _) = checkPat msg l e []
1023
1024 checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
1025 -> P (LPat GhcPs)
1026 checkPat _ loc (L l e@(HsVar _ (L _ c))) args
1027 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
1028 | not (null args) && patIsRec c =
1029 patFail (text "Perhaps you intended to use RecursiveDo") l e
1030 checkPat msg loc e args -- OK to let this happen even if bang-patterns
1031 -- are not enabled, because there is no valid
1032 -- non-bang-pattern parse of (C ! e)
1033 | Just (e', args') <- splitBang e
1034 = do { args'' <- checkPatterns msg args'
1035 ; checkPat msg loc e' (args'' ++ args) }
1036 checkPat msg loc (L _ (HsApp _ f e)) args
1037 = do p <- checkLPat msg e
1038 checkPat msg loc f (p : args)
1039 checkPat msg loc (L _ e) []
1040 = do p <- checkAPat msg loc e
1041 return (L loc p)
1042 checkPat msg loc e _
1043 = patFail msg loc (unLoc e)
1044
1045 checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
1046 checkAPat msg loc e0 = do
1047 pState <- getPState
1048 let opts = options pState
1049 case e0 of
1050 EWildPat _ -> return (WildPat noExt)
1051 HsVar _ x -> return (VarPat noExt x)
1052 HsLit _ (HsStringPrim _ _) -- (#13260)
1053 -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)
1054
1055 HsLit _ l -> return (LitPat noExt l)
1056
1057 -- Overloaded numeric patterns (e.g. f 0 x = x)
1058 -- Negation is recorded separately, so that the literal is zero or +ve
1059 -- NB. Negative *primitive* literals are already handled by the lexer
1060 HsOverLit _ pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
1061 NegApp _ (L l (HsOverLit _ pos_lit)) _
1062 -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
1063
1064 SectionR _ (L lb (HsVar _ (L _ bang))) e -- (! x)
1065 | bang == bang_RDR
1066 -> do { hintBangPat loc e0
1067 ; e' <- checkLPat msg e
1068 ; addAnnotation loc AnnBang lb
1069 ; return (BangPat noExt e') }
1070
1071 ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt))
1072 EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n)
1073 -- view pattern is well-formed if the pattern is
1074 EViewPat _ expr patE -> checkLPat msg patE >>=
1075 (return . (\p -> ViewPat noExt expr p))
1076 ExprWithTySig _ e t -> do e <- checkLPat msg e
1077 return (SigPat noExt e t)
1078
1079 -- n+k patterns
1080 OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
1081 (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
1082 | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
1083 -> return (mkNPlusKPat (L nloc n) (L lloc lit))
1084
1085 OpApp _ l (L cl (HsVar _ (L _ c))) r
1086 | isDataOcc (rdrNameOcc c) -> do
1087 l <- checkLPat msg l
1088 r <- checkLPat msg r
1089 return (ConPatIn (L cl c) (InfixCon l r))
1090
1091 OpApp {} -> patFail msg loc e0
1092
1093 ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
1094 return (ListPat noExt ps)
1095
1096 HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt))
1097
1098 ExplicitTuple _ es b
1099 | all tupArgPresent es -> do ps <- mapM (checkLPat msg)
1100 [e | L _ (Present _ e) <- es]
1101 return (TuplePat noExt ps b)
1102 | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
1103
1104 ExplicitSum _ alt arity expr -> do
1105 p <- checkLPat msg expr
1106 return (SumPat noExt p alt arity)
1107
1108 RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
1109 -> do fs <- mapM (checkPatField msg) fs
1110 return (ConPatIn c (RecCon (HsRecFields fs dd)))
1111 HsSpliceE _ s | not (isTypedSplice s)
1112 -> return (SplicePat noExt s)
1113 _ -> patFail msg loc e0
1114
1115 placeHolderPunRhs :: LHsExpr GhcPs
1116 -- The RHS of a punned record field will be filled in by the renamer
1117 -- It's better not to make it an error, in case we want to print it when debugging
1118 placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR))
1119
1120 plus_RDR, bang_RDR, pun_RDR :: RdrName
1121 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
1122 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
1123 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
1124
1125 checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
1126 -> P (LHsRecField GhcPs (LPat GhcPs))
1127 checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
1128 return (L l (fld { hsRecFieldArg = p }))
1129
1130 patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
1131 patFail msg loc e = parseErrorSDoc loc err
1132 where err = text "Parse error in pattern:" <+> ppr e
1133 $$ msg
1134
1135 patIsRec :: RdrName -> Bool
1136 patIsRec e = e == mkUnqual varName (fsLit "rec")
1137
1138
1139 ---------------------------------------------------------------------------
1140 -- Check Equation Syntax
1141
1142 checkValDef :: SDoc
1143 -> SrcStrictness
1144 -> LHsExpr GhcPs
1145 -> Maybe (LHsType GhcPs)
1146 -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
1147 -> P ([AddAnn],HsBind GhcPs)
1148
1149 checkValDef msg _strictness lhs (Just sig) grhss
1150 -- x :: ty = rhs parses as a *pattern* binding
1151 = checkPatBind msg (L (combineLocs lhs sig)
1152 (ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss
1153
1154 checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
1155 = do { mb_fun <- isFunLhs lhs
1156 ; case mb_fun of
1157 Just (fun, is_infix, pats, ann) ->
1158 checkFunBind msg strictness ann (getLoc lhs)
1159 fun is_infix pats (L l grhss)
1160 Nothing -> checkPatBind msg lhs g }
1161
1162 checkFunBind :: SDoc
1163 -> SrcStrictness
1164 -> [AddAnn]
1165 -> SrcSpan
1166 -> Located RdrName
1167 -> LexicalFixity
1168 -> [LHsExpr GhcPs]
1169 -> Located (GRHSs GhcPs (LHsExpr GhcPs))
1170 -> P ([AddAnn],HsBind GhcPs)
1171 checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
1172 = do ps <- checkPatterns msg pats
1173 let match_span = combineSrcSpans lhs_loc rhs_span
1174 -- Add back the annotations stripped from any HsPar values in the lhs
1175 -- mapM_ (\a -> a match_span) ann
1176 return (ann, makeFunBind fun
1177 [L match_span (Match { m_ext = noExt
1178 , m_ctxt = FunRhs { mc_fun = fun
1179 , mc_fixity = is_infix
1180 , mc_strictness = strictness }
1181 , m_pats = ps
1182 , m_grhss = grhss })])
1183 -- The span of the match covers the entire equation.
1184 -- That isn't quite right, but it'll do for now.
1185
1186 makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
1187 -> HsBind GhcPs
1188 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
1189 makeFunBind fn ms
1190 = FunBind { fun_ext = noExt,
1191 fun_id = fn,
1192 fun_matches = mkMatchGroup FromSource ms,
1193 fun_co_fn = idHsWrapper,
1194 fun_tick = [] }
1195
1196 checkPatBind :: SDoc
1197 -> LHsExpr GhcPs
1198 -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
1199 -> P ([AddAnn],HsBind GhcPs)
1200 checkPatBind msg lhs (L _ (_,grhss))
1201 = do { lhs <- checkPattern msg lhs
1202 ; return ([],PatBind noExt lhs grhss
1203 ([],[])) }
1204
1205 checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
1206 checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
1207 | isUnqual v
1208 , not (isDataOcc (rdrNameOcc v))
1209 = return lrdr
1210
1211 checkValSigLhs lhs@(L l _)
1212 = parseErrorSDoc l ((text "Invalid type signature:" <+>
1213 ppr lhs <+> text ":: ...")
1214 $$ text hint)
1215 where
1216 hint | foreign_RDR `looks_like` lhs
1217 = "Perhaps you meant to use ForeignFunctionInterface?"
1218 | default_RDR `looks_like` lhs
1219 = "Perhaps you meant to use DefaultSignatures?"
1220 | pattern_RDR `looks_like` lhs
1221 = "Perhaps you meant to use PatternSynonyms?"
1222 | otherwise
1223 = "Should be of form <variable> :: <type>"
1224
1225 -- A common error is to forget the ForeignFunctionInterface flag
1226 -- so check for that, and suggest. cf Trac #3805
1227 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
1228 looks_like s (L _ (HsVar _ (L _ v))) = v == s
1229 looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs
1230 looks_like _ _ = False
1231
1232 foreign_RDR = mkUnqual varName (fsLit "foreign")
1233 default_RDR = mkUnqual varName (fsLit "default")
1234 pattern_RDR = mkUnqual varName (fsLit "pattern")
1235
1236
1237 checkDoAndIfThenElse :: LHsExpr GhcPs
1238 -> Bool
1239 -> LHsExpr GhcPs
1240 -> Bool
1241 -> LHsExpr GhcPs
1242 -> P ()
1243 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
1244 | semiThen || semiElse
1245 = do pState <- getPState
1246 unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do
1247 parseErrorSDoc (combineLocs guardExpr elseExpr)
1248 (text "Unexpected semi-colons in conditional:"
1249 $$ nest 4 expr
1250 $$ text "Perhaps you meant to use DoAndIfThenElse?")
1251 | otherwise = return ()
1252 where pprOptSemi True = semi
1253 pprOptSemi False = empty
1254 expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
1255 text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
1256 text "else" <+> ppr elseExpr
1257
1258
1259 -- The parser left-associates, so there should
1260 -- not be any OpApps inside the e's
1261 splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
1262 -- Splits (f ! g a b) into (f, [(! g), a, b])
1263 splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg))
1264 | op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns)
1265 where
1266 l' = combineLocs bang arg1
1267 (arg1,argns) = split_bang r_arg []
1268 split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es)
1269 split_bang e es = (e,es)
1270 splitBang _ = Nothing
1271
1272 -- See Note [isFunLhs vs mergeDataCon]
1273 isFunLhs :: LHsExpr GhcPs
1274 -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn]))
1275 -- A variable binding is parsed as a FunBind.
1276 -- Just (fun, is_infix, arg_pats) if e is a function LHS
1277 --
1278 -- The whole LHS is parsed as a single expression.
1279 -- Any infix operators on the LHS will parse left-associatively
1280 -- E.g. f !x y !z
1281 -- will parse (rather strangely) as
1282 -- (f ! x y) ! z
1283 -- It's up to isFunLhs to sort out the mess
1284 --
1285 -- a .!. !b
1286
1287 isFunLhs e = go e [] []
1288 where
1289 go (L loc (HsVar _ (L _ f))) es ann
1290 | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
1291 go (L _ (HsApp _ f e)) es ann = go f (e:es) ann
1292 go (L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
1293
1294 -- Things of the form `!x` are also FunBinds
1295 -- See Note [FunBind vs PatBind]
1296 go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var)))))
1297 [] ann
1298 | bang == bang_RDR
1299 , not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann))
1300
1301 -- For infix function defns, there should be only one infix *function*
1302 -- (though there may be infix *datacons* involved too). So we don't
1303 -- need fixity info to figure out which function is being defined.
1304 -- a `K1` b `op` c `K2` d
1305 -- must parse as
1306 -- (a `K1` b) `op` (c `K2` d)
1307 -- The renamer checks later that the precedences would yield such a parse.
1308 --
1309 -- There is a complication to deal with bang patterns.
1310 --
1311 -- ToDo: what about this?
1312 -- x + 1 `op` y = ...
1313
1314 go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann
1315 | Just (e',es') <- splitBang e
1316 = do { bang_on <- extension bangPatEnabled
1317 ; if bang_on then go e' (es' ++ es) ann
1318 else return (Just (L loc' op, Infix, (l:r:es), ann)) }
1319 -- No bangs; behave just like the next case
1320 | not (isRdrDataCon op) -- We have found the function!
1321 = return (Just (L loc' op, Infix, (l:r:es), ann))
1322 | otherwise -- Infix data con; keep going
1323 = do { mb_l <- go l es ann
1324 ; case mb_l of
1325 Just (op', Infix, j : k : es', ann')
1326 -> return (Just (op', Infix, j : op_app : es', ann'))
1327 where
1328 op_app = L loc (OpApp noExt k
1329 (L loc' (HsVar noExt (L loc' op))) r)
1330 _ -> return Nothing }
1331 go _ _ _ = return Nothing
1332
1333 -- | Either an operator or an operand.
1334 data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
1335 | TyElTilde | TyElBang
1336 | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
1337 | TyElDocPrev HsDocString
1338
1339 instance Outputable TyEl where
1340 ppr (TyElOpr name) = ppr name
1341 ppr (TyElOpd ty) = ppr ty
1342 ppr TyElTilde = text "~"
1343 ppr TyElBang = text "!"
1344 ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk
1345 ppr (TyElDocPrev doc) = ppr doc
1346
1347 tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
1348 tyElStrictness TyElTilde = Just (AnnTilde, SrcLazy)
1349 tyElStrictness TyElBang = Just (AnnBang, SrcStrict)
1350 tyElStrictness _ = Nothing
1351
1352 -- | Extract a strictness/unpackedness annotation from the front of a reversed
1353 -- 'TyEl' list.
1354 pStrictMark
1355 :: [Located TyEl] -- reversed TyEl
1356 -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -}
1357 , [AddAnn]
1358 , [Located TyEl] {- remaining TyEl -})
1359 pStrictMark (L l1 x1 : L l2 x2 : xs)
1360 | Just (strAnnId, str) <- tyElStrictness x1
1361 , TyElUnpackedness (unpkAnns, prag, unpk) <- x2
1362 = Just ( L (combineSrcSpans l1 l2) (HsSrcBang prag unpk str)
1363 , unpkAnns ++ [\s -> addAnnotation s strAnnId l1]
1364 , xs )
1365 pStrictMark (L l x1 : xs)
1366 | Just (strAnnId, str) <- tyElStrictness x1
1367 = Just ( L l (HsSrcBang NoSourceText NoSrcUnpack str)
1368 , [\s -> addAnnotation s strAnnId l]
1369 , xs )
1370 pStrictMark (L l x1 : xs)
1371 | TyElUnpackedness (anns, prag, unpk) <- x1
1372 = Just ( L l (HsSrcBang prag unpk NoSrcStrict)
1373 , anns
1374 , xs )
1375 pStrictMark _ = Nothing
1376
1377 pBangTy
1378 :: LHsType GhcPs -- a type to be wrapped inside HsBangTy
1379 -> [Located TyEl] -- reversed TyEl
1380 -> ( Bool {- has a strict mark been consumed? -}
1381 , LHsType GhcPs {- the resulting BangTy -}
1382 , P () {- add annotations -}
1383 , [Located TyEl] {- remaining TyEl -})
1384 pBangTy lt@(L l1 _) xs =
1385 case pStrictMark xs of
1386 Nothing -> (False, lt, pure (), xs)
1387 Just (L l2 strictMark, anns, xs') ->
1388 let bl = combineSrcSpans l1 l2
1389 bt = HsBangTy noExt strictMark lt
1390 in (True, L bl bt, addAnnsAt bl anns, xs')
1391
1392 -- | Merge a /reversed/ and /non-empty/ soup of operators and operands
1393 -- into a type.
1394 --
1395 -- User input: @F x y + G a b * X@
1396 -- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F]
1397 -- Output corresponds to what the user wrote assuming all operators are of the
1398 -- same fixity and right-associative.
1399 --
1400 -- It's a bit silly that we're doing it at all, as the renamer will have to
1401 -- rearrange this, and it'd be easier to keep things separate.
1402 --
1403 -- See Note [Parsing data constructors is hard]
1404 mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
1405 mergeOps (L l1 (TyElOpd t) : xs)
1406 | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs
1407 , null xs' -- We accept a BangTy only when there are no preceding TyEl.
1408 = addAnns >> return t'
1409 mergeOps all_xs = go (0 :: Int) [] id all_xs
1410 where
1411 -- clause (err.1):
1412 -- we do not expect to encounter any (NO)UNPACK pragmas
1413 go k acc ops_acc (L l (TyElUnpackedness (_, unpkSrc, unpk)):_) =
1414 if not (null acc) && (k > 1 || length acc > 1)
1415 then failOpUnpackednessCompound (L l unpkSDoc) (ops_acc (mergeAcc acc))
1416 else failOpUnpackednessPosition (L l unpkSDoc)
1417 where
1418 unpkSDoc = case unpkSrc of
1419 NoSourceText -> ppr unpk
1420 SourceText str -> text str <> text " #-}"
1421
1422 -- clause (err.2):
1423 -- we do not expect to encounter any docs
1424 go _ _ _ (L l (TyElDocPrev _):_) =
1425 failOpDocPrev l
1426
1427 -- clause (err.3):
1428 -- to improve error messages, we do a bit of guesswork to determine if the
1429 -- user intended a '!' or a '~' as a strictness annotation
1430 go k acc ops_acc (L l x : xs)
1431 | Just (_, str) <- tyElStrictness x
1432 , let guess [] = True
1433 guess (L _ (TyElOpd _):_) = False
1434 guess (L _ (TyElOpr _):_) = True
1435 guess (L _ (TyElTilde):_) = True
1436 guess (L _ (TyElBang):_) = True
1437 guess (L _ (TyElUnpackedness _):_) = True
1438 guess (L _ (TyElDocPrev _):xs') = guess xs'
1439 in guess xs
1440 = if not (null acc) && (k > 1 || length acc > 1)
1441 then failOpStrictnessCompound (L l str) (ops_acc (mergeAcc acc))
1442 else failOpStrictnessPosition (L l str)
1443
1444 -- clause (a):
1445 -- when we encounter an operator, we must have accumulated
1446 -- something for its rhs, and there must be something left
1447 -- to build its lhs.
1448 go k acc ops_acc (L l (TyElOpr op):xs) =
1449 if null acc || null xs
1450 then failOpFewArgs (L l op)
1451 else do { let a = mergeAcc acc
1452 ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs }
1453
1454 -- clause (a.1): interpret 'TyElTilde' as an operator
1455 go k acc ops_acc (L l TyElTilde:xs) =
1456 let op = eqTyCon_RDR
1457 in go k acc ops_acc (L l (TyElOpr op):xs)
1458
1459 -- clause (a.2): interpret 'TyElBang' as an operator
1460 go k acc ops_acc (L l TyElBang:xs) =
1461 let op = mkUnqual tcClsName (fsLit "!")
1462 in go k acc ops_acc (L l (TyElOpr op):xs)
1463
1464 -- clause (b):
1465 -- whenever an operand is encountered, it is added to the accumulator
1466 go k acc ops_acc (L l (TyElOpd a):xs) = go k (L l a:acc) ops_acc xs
1467
1468 -- clause (c):
1469 -- at this point we know that 'acc' is non-empty because
1470 -- there are three options when 'acc' can be empty:
1471 -- 1. 'mergeOps' was called with an empty list, and this
1472 -- should never happen
1473 -- 2. 'mergeOps' was called with a list where the head is an
1474 -- operator, this is handled by clause (a)
1475 -- 3. 'mergeOps' was called with a list where the head is an
1476 -- operand, this is handled by clause (b)
1477 go _ acc ops_acc [] =
1478 return (ops_acc (mergeAcc acc))
1479
1480 mergeAcc [] = panic "mergeOps.mergeAcc: empty input"
1481 mergeAcc (x:xs) = mkHsAppTys x xs
1482
1483 pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
1484 pInfixSide (L l (TyElOpd t):xs)
1485 | (True, t', addAnns, xs') <- pBangTy (L l t) xs
1486 = Just (t', addAnns, xs')
1487 pInfixSide (L l1 (TyElOpd t1):xs1) = go [L l1 t1] xs1
1488 where
1489 go acc (L l (TyElOpd t):xs) = go (L l t:acc) xs
1490 go acc xs = Just (mergeAcc acc, pure (), xs)
1491 mergeAcc [] = panic "pInfixSide.mergeAcc: empty input"
1492 mergeAcc (x:xs) = mkHsAppTys x xs
1493 pInfixSide _ = Nothing
1494
1495 pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
1496 pDocPrev = go Nothing
1497 where
1498 go mTrailingDoc (L l (TyElDocPrev doc):xs) =
1499 go (mTrailingDoc `mplus` Just (L l doc)) xs
1500 go mTrailingDoc xs = (mTrailingDoc, xs)
1501
1502 orErr :: Maybe a -> b -> Either b a
1503 orErr (Just a) _ = Right a
1504 orErr Nothing b = Left b
1505
1506 {- Note [isFunLhs vs mergeDataCon]
1507 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1508
1509 When parsing a function LHS, we do not know whether to treat (!) as
1510 a strictness annotation or an infix operator:
1511
1512 f ! a = ...
1513
1514 Without -XBangPatterns, this parses as (!) f a = ...
1515 with -XBangPatterns, this parses as f (!a) = ...
1516
1517 So in function declarations we opted to always parse as if -XBangPatterns
1518 were off, and then rejig in 'isFunLhs'.
1519
1520 There are two downsides to this approach:
1521
1522 1. It is not particularly elegant, as there's a point in our pipeline where
1523 the representation is awfully incorrect. For instance,
1524 f !a b !c = ...
1525 will be first parsed as
1526 (f ! a b) ! c = ...
1527
1528 2. There are cases that it fails to cover, for instance infix declarations:
1529 !a + !b = ...
1530 will trigger an error.
1531
1532 Unfortunately, we cannot define different productions in the 'happy' grammar
1533 depending on whether -XBangPatterns are enabled.
1534
1535 When parsing data constructors, we face a similar issue:
1536 (a) data T1 = C ! D
1537 (b) data T2 = C ! D => ...
1538
1539 In (a) the first bang is a strictness annotation, but in (b) it is a type
1540 operator. A 'happy'-based parser does not have unlimited lookahead to check for
1541 =>, so we must first parse (C ! D) into a common representation.
1542
1543 If we tried to mirror the approach used in functions, we would parse both sides
1544 of => as types, and then rejig. However, we take a different route and use an
1545 intermediate data structure, a reversed list of 'TyEl'.
1546 See Note [Parsing data constructors is hard] for details.
1547
1548 This approach does not suffer from the issues of 'isFunLhs':
1549
1550 1. A sequence of 'TyEl' is a dedicated intermediate representation, not an
1551 incorrectly parsed type. Therefore, we do not have confusing states in our
1552 pipeline. (Except for representing data constructors as type variables).
1553
1554 2. We can handle infix data constructors with strictness annotations:
1555 data T a b = !a :+ !b
1556
1557 -}
1558
1559
1560 -- | Merge a /reversed/ and /non-empty/ soup of operators and operands
1561 -- into a data constructor.
1562 --
1563 -- User input: @C !A B -- ^ doc@
1564 -- Input to 'mergeDataCon': ["doc", B, !, A, C]
1565 -- Output: (C, PrefixCon [!A, B], "doc")
1566 --
1567 -- See Note [Parsing data constructors is hard]
1568 -- See Note [isFunLhs vs mergeDataCon]
1569 mergeDataCon
1570 :: [Located TyEl]
1571 -> P ( Located RdrName -- constructor name
1572 , HsConDeclDetails GhcPs -- constructor field information
1573 , Maybe LHsDocString -- docstring to go on the constructor
1574 )
1575 mergeDataCon all_xs =
1576 do { (addAnns, a) <- eitherToP res
1577 ; addAnns
1578 ; return a }
1579 where
1580 -- We start by splitting off the trailing documentation comment,
1581 -- if any exists.
1582 (mTrailingDoc, all_xs') = pDocPrev all_xs
1583
1584 -- Determine whether the trailing documentation comment exists and is the
1585 -- only docstring in this constructor declaration.
1586 --
1587 -- When true, it means that it applies to the constructor itself:
1588 -- data T = C
1589 -- A
1590 -- B -- ^ Comment on C (singleDoc == True)
1591 --
1592 -- When false, it means that it applies to the last field:
1593 -- data T = C -- ^ Comment on C
1594 -- A -- ^ Comment on A
1595 -- B -- ^ Comment on B (singleDoc == False)
1596 singleDoc = isJust mTrailingDoc &&
1597 null [ () | L _ (TyElDocPrev _) <- all_xs' ]
1598
1599 -- The result of merging the list of reversed TyEl into a
1600 -- data constructor, along with [AddAnn].
1601 res = goFirst all_xs'
1602
1603 -- Take the trailing docstring into account when interpreting
1604 -- the docstring near the constructor.
1605 --
1606 -- data T = C -- ^ docstring right after C
1607 -- A
1608 -- B -- ^ trailing docstring
1609 --
1610 -- 'mkConDoc' must be applied to the docstring right after C, so that it
1611 -- falls back to the trailing docstring when appropriate (see singleDoc).
1612 mkConDoc mDoc | singleDoc = mDoc `mplus` mTrailingDoc
1613 | otherwise = mDoc
1614
1615 -- The docstring for the last field of a data constructor.
1616 trailingFieldDoc | singleDoc = Nothing
1617 | otherwise = mTrailingDoc
1618
1619 goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
1620 = do { data_con <- tyConToDataCon l tc
1621 ; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) }
1622 goFirst (L l (TyElOpd (HsRecTy _ fields)):xs)
1623 | (mConDoc, xs') <- pDocPrev xs
1624 , [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs'
1625 = do { data_con <- tyConToDataCon l' tc
1626 ; let mDoc = mTrailingDoc `mplus` mConDoc
1627 ; return (pure (), (data_con, RecCon (L l fields), mDoc)) }
1628 goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
1629 = return ( pure ()
1630 , ( L l (getRdrName (tupleDataCon Boxed (length ts)))
1631 , PrefixCon ts
1632 , mTrailingDoc ) )
1633 goFirst (L l (TyElOpd t):xs)
1634 | (_, t', addAnns, xs') <- pBangTy (L l t) xs
1635 = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs'
1636 goFirst xs =
1637 go (pure ()) mTrailingDoc [] xs
1638
1639 go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
1640 = do { data_con <- tyConToDataCon l tc
1641 ; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) }
1642 go addAnns mLastDoc ts (L l (TyElDocPrev doc):xs) =
1643 go addAnns (mLastDoc `mplus` Just (L l doc)) ts xs
1644 go addAnns mLastDoc ts (L l (TyElOpd t):xs)
1645 | (_, t', addAnns', xs') <- pBangTy (L l t) xs
1646 , t'' <- mkLHsDocTyMaybe t' mLastDoc
1647 = go (addAnns >> addAnns') Nothing (t'':ts) xs'
1648 go _ _ _ (L _ (TyElOpr _):_) =
1649 -- Encountered an operator: backtrack to the beginning and attempt
1650 -- to parse as an infix definition.
1651 goInfix
1652 go _ _ _ _ = Left malformedErr
1653 where
1654 malformedErr =
1655 ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs')
1656 , text "Cannot parse data constructor" <+>
1657 text "in a data/newtype declaration:" $$
1658 nest 2 (hsep . reverse $ map ppr all_xs'))
1659
1660 goInfix =
1661 do { let xs0 = all_xs'
1662 ; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr
1663 ; let (mOpDoc, xs2) = pDocPrev xs1
1664 ; (op, xs3) <- case xs2 of
1665 L l (TyElOpr op) : xs3 ->
1666 do { data_con <- tyConToDataCon l op
1667 ; return (data_con, xs3) }
1668 _ -> Left malformedErr
1669 ; let (mLhsDoc, xs4) = pDocPrev xs3
1670 ; (lhs_t, lhs_addAnns, xs5) <- pInfixSide xs4 `orErr` malformedErr
1671 ; unless (null xs5) (Left malformedErr)
1672 ; let rhs = mkLHsDocTyMaybe rhs_t trailingFieldDoc
1673 lhs = mkLHsDocTyMaybe lhs_t mLhsDoc
1674 addAnns = lhs_addAnns >> rhs_addAnns
1675 ; return (addAnns, (op, InfixCon lhs rhs, mkConDoc mOpDoc)) }
1676 where
1677 malformedErr =
1678 ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs')
1679 , text "Cannot parse an infix data constructor" <+>
1680 text "in a data/newtype declaration:" $$
1681 nest 2 (hsep . reverse $ map ppr all_xs'))
1682
1683 ---------------------------------------------------------------------------
1684 -- Check for monad comprehensions
1685 --
1686 -- If the flag MonadComprehensions is set, return a `MonadComp' context,
1687 -- otherwise use the usual `ListComp' context
1688
1689 checkMonadComp :: P (HsStmtContext Name)
1690 checkMonadComp = do
1691 pState <- getPState
1692 return $ if extopt LangExt.MonadComprehensions (options pState)
1693 then MonadComp
1694 else ListComp
1695
1696 -- -------------------------------------------------------------------------
1697 -- Checking arrow syntax.
1698
1699 -- We parse arrow syntax as expressions and check for valid syntax below,
1700 -- converting the expression into a pattern at the same time.
1701
1702 checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
1703 checkCommand lc = locMap checkCmd lc
1704
1705 locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
1706 locMap f (L l a) = f l a >>= (\b -> return $ L l b)
1707
1708 checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
1709 checkCmd _ (HsArrApp _ e1 e2 haat b) =
1710 return $ HsCmdArrApp noExt e1 e2 haat b
1711 checkCmd _ (HsArrForm _ e mf args) =
1712 return $ HsCmdArrForm noExt e Prefix mf args
1713 checkCmd _ (HsApp _ e1 e2) =
1714 checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2)
1715 checkCmd _ (HsLam _ mg) =
1716 checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg')
1717 checkCmd _ (HsPar _ e) =
1718 checkCommand e >>= (\c -> return $ HsCmdPar noExt c)
1719 checkCmd _ (HsCase _ e mg) =
1720 checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg')
1721 checkCmd _ (HsIf _ cf ep et ee) = do
1722 pt <- checkCommand et
1723 pe <- checkCommand ee
1724 return $ HsCmdIf noExt cf ep pt pe
1725 checkCmd _ (HsLet _ lb e) =
1726 checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
1727 checkCmd _ (HsDo _ DoExpr (L l stmts)) =
1728 mapM checkCmdLStmt stmts >>=
1729 (\ss -> return $ HsCmdDo noExt (L l ss) )
1730
1731 checkCmd _ (OpApp _ eLeft op eRight) = do
1732 -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
1733 c1 <- checkCommand eLeft
1734 c2 <- checkCommand eRight
1735 let arg1 = L (getLoc c1) $ HsCmdTop noExt c1
1736 arg2 = L (getLoc c2) $ HsCmdTop noExt c2
1737 return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]
1738
1739 checkCmd l e = cmdFail l e
1740
1741 checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
1742 checkCmdLStmt = locMap checkCmdStmt
1743
1744 checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
1745 checkCmdStmt _ (LastStmt x e s r) =
1746 checkCommand e >>= (\c -> return $ LastStmt x c s r)
1747 checkCmdStmt _ (BindStmt x pat e b f) =
1748 checkCommand e >>= (\c -> return $ BindStmt x pat c b f)
1749 checkCmdStmt _ (BodyStmt x e t g) =
1750 checkCommand e >>= (\c -> return $ BodyStmt x c t g)
1751 checkCmdStmt _ (LetStmt x bnds) = return $ LetStmt x bnds
1752 checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
1753 ss <- mapM checkCmdLStmt stmts
1754 return $ stmt { recS_ext = noExt, recS_stmts = ss }
1755 checkCmdStmt _ (XStmtLR _) = panic "checkCmdStmt"
1756 checkCmdStmt l stmt = cmdStmtFail l stmt
1757
1758 checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
1759 -> P (MatchGroup GhcPs (LHsCmd GhcPs))
1760 checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
1761 ms' <- mapM (locMap $ const convert) ms
1762 return $ mg { mg_ext = noExt, mg_alts = L l ms' }
1763 where convert match@(Match { m_grhss = grhss }) = do
1764 grhss' <- checkCmdGRHSs grhss
1765 return $ match { m_ext = noExt, m_grhss = grhss'}
1766 convert (XMatch _) = panic "checkCmdMatchGroup.XMatch"
1767 checkCmdMatchGroup (XMatchGroup {}) = panic "checkCmdMatchGroup"
1768
1769 checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
1770 checkCmdGRHSs (GRHSs x grhss binds) = do
1771 grhss' <- mapM checkCmdGRHS grhss
1772 return $ GRHSs x grhss' binds
1773 checkCmdGRHSs (XGRHSs _) = panic "checkCmdGRHSs"
1774
1775 checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
1776 checkCmdGRHS = locMap $ const convert
1777 where
1778 convert (GRHS x stmts e) = do
1779 c <- checkCommand e
1780 -- cmdStmts <- mapM checkCmdLStmt stmts
1781 return $ GRHS x {- cmdStmts -} stmts c
1782 convert (XGRHS _) = panic "checkCmdGRHS"
1783
1784
1785 cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
1786 cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
1787 cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a
1788 cmdStmtFail loc e = parseErrorSDoc loc
1789 (text "Parse error in command statement:" <+> ppr e)
1790
1791 ---------------------------------------------------------------------------
1792 -- Miscellaneous utilities
1793
1794 -- | Check if a fixity is valid. We support bypassing the usual bound checks
1795 -- for some special operators.
1796 checkPrecP
1797 :: Located (SourceText,Int) -- ^ precedence
1798 -> Located (OrdList (Located RdrName)) -- ^ operators
1799 -> P ()
1800 checkPrecP (L l (_,i)) (L _ ol)
1801 | 0 <= i, i <= maxPrecedence = pure ()
1802 | all specialOp ol = pure ()
1803 | otherwise = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
1804 where
1805 specialOp op = unLoc op `elem` [ eqTyCon_RDR
1806 , getRdrName funTyCon ]
1807
1808 mkRecConstrOrUpdate
1809 :: LHsExpr GhcPs
1810 -> SrcSpan
1811 -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
1812 -> P (HsExpr GhcPs)
1813
1814 mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
1815 | isRdrDataCon c
1816 = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
1817 mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
1818 | dd = parseErrorSDoc l (text "You cannot use `..' in a record update")
1819 | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
1820
1821 mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
1822 mkRdrRecordUpd exp flds
1823 = RecordUpd { rupd_ext = noExt
1824 , rupd_expr = exp
1825 , rupd_flds = flds }
1826
1827 mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
1828 mkRdrRecordCon con flds
1829 = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds }
1830
1831 mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
1832 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
1833 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
1834
1835 mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
1836 mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
1837 = HsRecField (L loc (Unambiguous noExt rdr)) arg pun
1838 mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _)
1839 = panic "mk_rec_upd_field"
1840
1841 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
1842 -> InlinePragma
1843 -- The (Maybe Activation) is because the user can omit
1844 -- the activation spec (and usually does)
1845 mkInlinePragma src (inl, match_info) mb_act
1846 = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes
1847 , inl_inline = inl
1848 , inl_sat = Nothing
1849 , inl_act = act
1850 , inl_rule = match_info }
1851 where
1852 act = case mb_act of
1853 Just act -> act
1854 Nothing -> -- No phase specified
1855 case inl of
1856 NoInline -> NeverActive
1857 _other -> AlwaysActive
1858
1859 -----------------------------------------------------------------------------
1860 -- utilities for foreign declarations
1861
1862 -- construct a foreign import declaration
1863 --
1864 mkImport :: Located CCallConv
1865 -> Located Safety
1866 -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
1867 -> P (HsDecl GhcPs)
1868 mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
1869 case cconv of
1870 L _ CCallConv -> mkCImport
1871 L _ CApiConv -> mkCImport
1872 L _ StdCallConv -> mkCImport
1873 L _ PrimCallConv -> mkOtherImport
1874 L _ JavaScriptCallConv -> mkOtherImport
1875 where
1876 -- Parse a C-like entity string of the following form:
1877 -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"
1878 -- If 'cid' is missing, the function name 'v' is used instead as symbol
1879 -- name (cf section 8.5.1 in Haskell 2010 report).
1880 mkCImport = do
1881 let e = unpackFS entity
1882 case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
1883 Nothing -> parseErrorSDoc loc (text "Malformed entity string")
1884 Just importSpec -> returnSpec importSpec
1885
1886 -- currently, all the other import conventions only support a symbol name in
1887 -- the entity string. If it is missing, we use the function name instead.
1888 mkOtherImport = returnSpec importSpec
1889 where
1890 entity' = if nullFS entity
1891 then mkExtName (unLoc v)
1892 else entity
1893 funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
1894 importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
1895
1896 returnSpec spec = return $ ForD noExt $ ForeignImport
1897 { fd_i_ext = noExt
1898 , fd_name = v
1899 , fd_sig_ty = ty
1900 , fd_fi = spec
1901 }
1902
1903
1904
1905 -- the string "foo" is ambiguous: either a header or a C identifier. The
1906 -- C identifier case comes first in the alternatives below, so we pick
1907 -- that one.
1908 parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
1909 -> Located SourceText
1910 -> Maybe ForeignImport
1911 parseCImport cconv safety nm str sourceText =
1912 listToMaybe $ map fst $ filter (null.snd) $
1913 readP_to_S parse str
1914 where
1915 parse = do
1916 skipSpaces
1917 r <- choice [
1918 string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
1919 string "wrapper" >> return (mk Nothing CWrapper),
1920 do optional (token "static" >> skipSpaces)
1921 ((mk Nothing <$> cimp nm) +++
1922 (do h <- munch1 hdr_char
1923 skipSpaces
1924 mk (Just (Header (SourceText h) (mkFastString h)))
1925 <$> cimp nm))
1926 ]
1927 skipSpaces
1928 return r
1929
1930 token str = do _ <- string str
1931 toks <- look
1932 case toks of
1933 c : _
1934 | id_char c -> pfail
1935 _ -> return ()
1936
1937 mk h n = CImport cconv safety h n sourceText
1938
1939 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
1940 -- pretty much any char (depending on the platform),
1941 -- so just accept any non-space character
1942 id_first_char c = isAlpha c || c == '_'
1943 id_char c = isAlphaNum c || c == '_'
1944
1945 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1946 +++ (do isFun <- case cconv of
1947 L _ CApiConv ->
1948 option True
1949 (do token "value"
1950 skipSpaces
1951 return False)
1952 _ -> return True
1953 cid' <- cid
1954 return (CFunction (StaticTarget NoSourceText cid'
1955 Nothing isFun)))
1956 where
1957 cid = return nm +++
1958 (do c <- satisfy id_first_char
1959 cs <- many (satisfy id_char)
1960 return (mkFastString (c:cs)))
1961
1962
1963 -- construct a foreign export declaration
1964 --
1965 mkExport :: Located CCallConv
1966 -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
1967 -> P (HsDecl GhcPs)
1968 mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
1969 = return $ ForD noExt $
1970 ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty
1971 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
1972 (L le esrc) }
1973 where
1974 entity' | nullFS entity = mkExtName (unLoc v)
1975 | otherwise = entity
1976
1977 -- Supplying the ext_name in a foreign decl is optional; if it
1978 -- isn't there, the Haskell name is assumed. Note that no transformation
1979 -- of the Haskell name is then performed, so if you foreign export (++),
1980 -- it's external name will be "++". Too bad; it's important because we don't
1981 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1982 --
1983 mkExtName :: RdrName -> CLabelString
1984 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1985
1986 --------------------------------------------------------------------------------
1987 -- Help with module system imports/exports
1988
1989 data ImpExpSubSpec = ImpExpAbs
1990 | ImpExpAll
1991 | ImpExpList [Located ImpExpQcSpec]
1992 | ImpExpAllWith [Located ImpExpQcSpec]
1993
1994 data ImpExpQcSpec = ImpExpQcName (Located RdrName)
1995 | ImpExpQcType (Located RdrName)
1996 | ImpExpQcWildcard
1997
1998 mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
1999 mkModuleImpExp (L l specname) subs =
2000 case subs of
2001 ImpExpAbs
2002 | isVarNameSpace (rdrNameSpace name)
2003 -> return $ IEVar noExt (L l (ieNameFromSpec specname))
2004 | otherwise -> IEThingAbs noExt . L l <$> nameT
2005 ImpExpAll -> IEThingAll noExt . L l <$> nameT
2006 ImpExpList xs ->
2007 (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) [])
2008 <$> nameT
2009 ImpExpAllWith xs ->
2010 do allowed <- extension patternSynonymsEnabled
2011 if allowed
2012 then
2013 let withs = map unLoc xs
2014 pos = maybe NoIEWildcard IEWildcard
2015 (findIndex isImpExpQcWildcard withs)
2016 ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
2017 in (\newName
2018 -> IEThingWith noExt (L l newName) pos ies []) <$> nameT
2019 else parseErrorSDoc l
2020 (text "Illegal export form (use PatternSynonyms to enable)")
2021 where
2022 name = ieNameVal specname
2023 nameT =
2024 if isVarNameSpace (rdrNameSpace name)
2025 then parseErrorSDoc l
2026 (text "Expecting a type constructor but found a variable,"
2027 <+> quotes (ppr name) <> text "."
2028 $$ if isSymOcc $ rdrNameOcc name
2029 then text "If" <+> quotes (ppr name) <+> text "is a type constructor"
2030 <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
2031 else empty)
2032 else return $ ieNameFromSpec specname
2033
2034 ieNameVal (ImpExpQcName ln) = unLoc ln
2035 ieNameVal (ImpExpQcType ln) = unLoc ln
2036 ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard"
2037
2038 ieNameFromSpec (ImpExpQcName ln) = IEName ln
2039 ieNameFromSpec (ImpExpQcType ln) = IEType ln
2040 ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
2041
2042 wrapped = map (\(L l x) -> L l (ieNameFromSpec x))
2043
2044 mkTypeImpExp :: Located RdrName -- TcCls or Var name space
2045 -> P (Located RdrName)
2046 mkTypeImpExp name =
2047 do allowed <- extension explicitNamespacesEnabled
2048 if allowed
2049 then return (fmap (`setRdrNameSpace` tcClsName) name)
2050 else parseErrorSDoc (getLoc name)
2051 (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
2052
2053 checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
2054 checkImportSpec ie@(L _ specs) =
2055 case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
2056 [] -> return ie
2057 (l:_) -> importSpecError l
2058 where
2059 importSpecError l =
2060 parseErrorSDoc l
2061 (text "Illegal import form, this syntax can only be used to bundle"
2062 $+$ text "pattern synonyms with types in module exports.")
2063
2064 -- In the correct order
2065 mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
2066 mkImpExpSubSpec [] = return ([], ImpExpList [])
2067 mkImpExpSubSpec [L _ ImpExpQcWildcard] =
2068 return ([], ImpExpAll)
2069 mkImpExpSubSpec xs =
2070 if (any (isImpExpQcWildcard . unLoc) xs)
2071 then return $ ([], ImpExpAllWith xs)
2072 else return $ ([], ImpExpList xs)
2073
2074 isImpExpQcWildcard :: ImpExpQcSpec -> Bool
2075 isImpExpQcWildcard ImpExpQcWildcard = True
2076 isImpExpQcWildcard _ = False
2077
2078 -----------------------------------------------------------------------------
2079 -- Warnings and failures
2080
2081 warnStarIsType :: SrcSpan -> P ()
2082 warnStarIsType span = addWarning Opt_WarnStarIsType span msg
2083 where
2084 msg = text "Using" <+> quotes (text "*")
2085 <+> text "(or its Unicode variant) to mean"
2086 <+> quotes (text "Data.Kind.Type")
2087 $$ text "relies on the StarIsType extension, which will become"
2088 $$ text "deprecated in the future."
2089 $$ text "Suggested fix: use" <+> quotes (text "Type")
2090 <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
2091
2092 warnStarBndr :: SrcSpan -> P ()
2093 warnStarBndr span = addWarning Opt_WarnStarBinder span msg
2094 where
2095 msg = text "Found binding occurrence of" <+> quotes (text "*")
2096 <+> text "yet StarIsType is enabled."
2097 $$ text "NB. To use (or export) this operator in"
2098 <+> text "modules with StarIsType,"
2099 $$ text " including the definition module, you must qualify it."
2100
2101 failOpFewArgs :: Located RdrName -> P a
2102 failOpFewArgs (L loc op) =
2103 do { star_is_type <- extension starIsTypeEnabled
2104 ; let msg = too_few $$ starInfo star_is_type op
2105 ; parseErrorSDoc loc msg }
2106 where
2107 too_few = text "Operator applied to too few arguments:" <+> ppr op
2108
2109 failOpDocPrev :: SrcSpan -> P a
2110 failOpDocPrev loc = parseErrorSDoc loc msg
2111 where
2112 msg = text "Unexpected documentation comment."
2113
2114 failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a
2115 failOpStrictnessCompound (L _ str) (L loc ty) = parseErrorSDoc loc msg
2116 where
2117 msg = text "Strictness annotation applied to a compound type." $$
2118 text "Did you mean to add parentheses?" $$
2119 nest 2 (ppr str <> parens (ppr ty))
2120
2121 failOpStrictnessPosition :: Located SrcStrictness -> P a
2122 failOpStrictnessPosition (L loc _) = parseErrorSDoc loc msg
2123 where
2124 msg = text "Strictness annotation cannot appear in this position."
2125
2126 failOpUnpackednessCompound :: Located SDoc -> LHsType GhcPs -> P a
2127 failOpUnpackednessCompound (L _ unpkSDoc) (L loc ty) = parseErrorSDoc loc msg
2128 where
2129 msg = unpkSDoc <+> text "applied to a compound type." $$
2130 text "Did you mean to add parentheses?" $$
2131 nest 2 (unpkSDoc <+> parens (ppr ty))
2132
2133 failOpUnpackednessPosition :: Located SDoc -> P a
2134 failOpUnpackednessPosition (L loc unpkSDoc) = parseErrorSDoc loc msg
2135 where
2136 msg = unpkSDoc <+> text "cannot appear in this position."
2137
2138 -----------------------------------------------------------------------------
2139 -- Misc utils
2140
2141 parseErrorSDoc :: SrcSpan -> SDoc -> P a
2142 parseErrorSDoc span s = failSpanMsgP span s
2143
2144 -- | Hint about bang patterns, assuming @BangPatterns@ is off.
2145 hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
2146 hintBangPat span e = do
2147 bang_on <- extension bangPatEnabled
2148 unless bang_on $
2149 parseErrorSDoc span
2150 (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
2151
2152 data SumOrTuple
2153 = Sum ConTag Arity (LHsExpr GhcPs)
2154 | Tuple [LHsTupArg GhcPs]
2155
2156 mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)
2157
2158 -- Tuple
2159 mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
2160
2161 -- Sum
2162 mkSumOrTuple Unboxed _ (Sum alt arity e) =
2163 return (ExplicitSum noExt alt arity e)
2164 mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
2165 parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
2166 where
2167 ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc
2168 ppr_boxed_sum alt arity e =
2169 text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"
2170
2171 ppr_bars n = hsep (replicate n (Outputable.char '|'))
2172
2173 mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
2174 mkLHsOpTy x op y =
2175 let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
2176 in L loc (mkHsOpTy x op y)
2177
2178 mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs
2179 mkLHsDocTy t doc =
2180 let loc = getLoc t `combineSrcSpans` getLoc doc
2181 in L loc (HsDocTy noExt t doc)
2182
2183 mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
2184 mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t)