never executed always true always false
1
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE GADTs #-}
6 {-# LANGUAGE LambdaCase #-}
7 {-# LANGUAGE RankNTypes #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# LANGUAGE ViewPatterns #-}
10 {-# LANGUAGE DataKinds #-}
11
12 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
13
14 --
15 -- (c) The University of Glasgow 2002-2006
16 --
17
18 -- Functions over HsSyn specialised to RdrName.
19
20 module GHC.Parser.PostProcess (
21 mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot
22 mkHsOpApp,
23 mkHsIntegral, mkHsFractional, mkHsIsString,
24 mkHsDo, mkSpliceDecl,
25 mkRoleAnnotDecl,
26 mkClassDecl,
27 mkTyData, mkDataFamInst,
28 mkTySynonym, mkTyFamInstEqn,
29 mkStandaloneKindSig,
30 mkTyFamInst,
31 mkFamDecl,
32 mkInlinePragma,
33 mkPatSynMatchGroup,
34 mkRecConstrOrUpdate,
35 mkTyClD, mkInstD,
36 mkRdrRecordCon, mkRdrRecordUpd,
37 setRdrNameSpace,
38 fromSpecTyVarBndr, fromSpecTyVarBndrs,
39 annBinds,
40
41 cvBindGroup,
42 cvBindsAndSigs,
43 cvTopDecls,
44 placeHolderPunRhs,
45
46 -- Stuff to do with Foreign declarations
47 mkImport,
48 parseCImport,
49 mkExport,
50 mkExtName, -- RdrName -> CLabelString
51 mkGadtDecl, -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName
52 mkConDeclH98,
53
54 -- Bunch of functions in the parser monad for
55 -- checking and constructing values
56 checkImportDecl,
57 checkExpBlockArguments, checkCmdBlockArguments,
58 checkPrecP, -- Int -> P Int
59 checkContext, -- HsType -> P HsContext
60 checkPattern, -- HsExp -> P HsPat
61 checkPattern_details,
62 incompleteDoBlock,
63 ParseContext(..),
64 checkMonadComp, -- P (HsStmtContext GhcPs)
65 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
66 checkValSigLhs,
67 LRuleTyTmVar, RuleTyTmVar(..),
68 mkRuleBndrs, mkRuleTyVarBndrs,
69 checkRuleTyVarBndrNames,
70 checkRecordSyntax,
71 checkEmptyGADTs,
72 addFatalError, hintBangPat,
73 mkBangTy,
74 UnpackednessPragma(..),
75 mkMultTy,
76
77 -- Token location
78 mkTokenLocation,
79
80 -- Help with processing exports
81 ImpExpSubSpec(..),
82 ImpExpQcSpec(..),
83 mkModuleImpExp,
84 mkTypeImpExp,
85 mkImpExpSubSpec,
86 checkImportSpec,
87
88 -- Token symbols
89 starSym,
90
91 -- Warnings and errors
92 warnStarIsType,
93 warnPrepositiveQualifiedModule,
94 failOpFewArgs,
95 failOpNotEnabledImportQualifiedPost,
96 failOpImportQualifiedTwice,
97
98 SumOrTuple (..),
99
100 -- Expression/command/pattern ambiguity resolution
101 PV,
102 runPV,
103 ECP(ECP, unECP),
104 DisambInfixOp(..),
105 DisambECP(..),
106 ecpFromExp,
107 ecpFromCmd,
108 PatBuilder,
109
110 -- Type/datacon ambiguity resolution
111 DisambTD(..),
112 addUnpackednessP,
113 dataConBuilderCon,
114 dataConBuilderDetails,
115 ) where
116
117 import GHC.Prelude
118 import GHC.Hs -- Lots of it
119 import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
120 import GHC.Core.DataCon ( DataCon, dataConTyCon )
121 import GHC.Core.ConLike ( ConLike(..) )
122 import GHC.Core.Coercion.Axiom ( Role, fsFromRole )
123 import GHC.Types.Name.Reader
124 import GHC.Types.Name
125 import GHC.Unit.Module (ModuleName)
126 import GHC.Types.Basic
127 import GHC.Types.Error
128 import GHC.Types.Fixity
129 import GHC.Types.SourceText
130 import GHC.Parser.Types
131 import GHC.Parser.Lexer
132 import GHC.Parser.Errors.Types
133 import GHC.Parser.Errors.Ppr ()
134 import GHC.Utils.Lexeme ( isLexCon )
135 import GHC.Types.TyThing
136 import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) )
137 import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
138 nilDataConName, nilDataConKey,
139 listTyConName, listTyConKey, eqTyCon_RDR )
140 import GHC.Types.ForeignCall
141 import GHC.Types.SrcLoc
142 import GHC.Types.Unique ( hasKey )
143 import GHC.Data.OrdList
144 import GHC.Utils.Outputable as Outputable
145 import GHC.Data.FastString
146 import GHC.Data.Maybe
147 import GHC.Utils.Error
148 import GHC.Utils.Misc
149 import Data.Either
150 import Data.List ( findIndex )
151 import Data.Foldable
152 import qualified Data.Semigroup as Semi
153 import GHC.Utils.Panic
154 import GHC.Utils.Panic.Plain
155 import qualified GHC.Data.Strict as Strict
156
157 import Control.Monad
158 import Text.ParserCombinators.ReadP as ReadP
159 import Data.Char
160 import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
161 import Data.Kind ( Type )
162
163 {- **********************************************************************
164
165 Construction functions for Rdr stuff
166
167 ********************************************************************* -}
168
169 -- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and
170 -- datacon by deriving them from the name of the class. We fill in the names
171 -- for the tycon and datacon corresponding to the class, by deriving them
172 -- from the name of the class itself. This saves recording the names in the
173 -- interface file (which would be equally good).
174
175 -- Similarly for mkConDecl, mkClassOpSig and default-method names.
176
177 -- *** See Note [The Naming story] in GHC.Hs.Decls ****
178
179 mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
180 mkTyClD (L loc d) = L loc (TyClD noExtField d)
181
182 mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
183 mkInstD (L loc d) = L loc (InstD noExtField d)
184
185 mkClassDecl :: SrcSpan
186 -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
187 -> Located (a,[LHsFunDep GhcPs])
188 -> OrdList (LHsDecl GhcPs)
189 -> LayoutInfo
190 -> [AddEpAnn]
191 -> P (LTyClDecl GhcPs)
192
193 mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn
194 = do { let loc = noAnnSrcSpan loc'
195 ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
196 ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
197 ; tyvars <- checkTyVars (text "class") whereDots cls tparams
198 ; cs <- getCommentsFor (locA loc) -- Get any remaining comments
199 ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs
200 ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey, layoutInfo)
201 , tcdCtxt = mcxt
202 , tcdLName = cls, tcdTyVars = tyvars
203 , tcdFixity = fixity
204 , tcdFDs = snd (unLoc fds)
205 , tcdSigs = mkClassOpSigs sigs
206 , tcdMeths = binds
207 , tcdATs = ats, tcdATDefs = at_defs
208 , tcdDocs = docs })) }
209
210 mkTyData :: SrcSpan
211 -> NewOrData
212 -> Maybe (LocatedP CType)
213 -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
214 -> Maybe (LHsKind GhcPs)
215 -> [LConDecl GhcPs]
216 -> Located (HsDeriving GhcPs)
217 -> [AddEpAnn]
218 -> P (LTyClDecl GhcPs)
219 mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr))
220 ksig data_cons (L _ maybe_deriv) annsIn
221 = do { let loc = noAnnSrcSpan loc'
222 ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
223 ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
224 ; cs <- getCommentsFor (locA loc) -- Get any remaining comments
225 ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs
226 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
227 ; return (L loc (DataDecl { tcdDExt = anns',
228 tcdLName = tc, tcdTyVars = tyvars,
229 tcdFixity = fixity,
230 tcdDataDefn = defn })) }
231
232 mkDataDefn :: NewOrData
233 -> Maybe (LocatedP CType)
234 -> Maybe (LHsContext GhcPs)
235 -> Maybe (LHsKind GhcPs)
236 -> [LConDecl GhcPs]
237 -> HsDeriving GhcPs
238 -> P (HsDataDefn GhcPs)
239 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
240 = do { checkDatatypeContext mcxt
241 ; return (HsDataDefn { dd_ext = noExtField
242 , dd_ND = new_or_data, dd_cType = cType
243 , dd_ctxt = mcxt
244 , dd_cons = data_cons
245 , dd_kindSig = ksig
246 , dd_derivs = maybe_deriv }) }
247
248
249 mkTySynonym :: SrcSpan
250 -> LHsType GhcPs -- LHS
251 -> LHsType GhcPs -- RHS
252 -> [AddEpAnn]
253 -> P (LTyClDecl GhcPs)
254 mkTySynonym loc lhs rhs annsIn
255 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
256 ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]
257 ; tyvars <- checkTyVars (text "type") equalsDots tc tparams
258 ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]
259 ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2)
260 ; return (L (noAnnSrcSpan loc) (SynDecl
261 { tcdSExt = anns'
262 , tcdLName = tc, tcdTyVars = tyvars
263 , tcdFixity = fixity
264 , tcdRhs = rhs })) }
265
266 mkStandaloneKindSig
267 :: SrcSpan
268 -> Located [LocatedN RdrName] -- LHS
269 -> LHsSigType GhcPs -- RHS
270 -> [AddEpAnn]
271 -> P (LStandaloneKindSig GhcPs)
272 mkStandaloneKindSig loc lhs rhs anns =
273 do { vs <- mapM check_lhs_name (unLoc lhs)
274 ; v <- check_singular_lhs (reverse vs)
275 ; cs <- getCommentsFor loc
276 ; return $ L (noAnnSrcSpan loc)
277 $ StandaloneKindSig (EpAnn (spanAsAnchor loc) anns cs) v rhs }
278 where
279 check_lhs_name v@(unLoc->name) =
280 if isUnqual name && isTcOcc (rdrNameOcc name)
281 then return v
282 else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $
283 (PsErrUnexpectedQualifiedConstructor (unLoc v))
284 check_singular_lhs vs =
285 case vs of
286 [] -> panic "mkStandaloneKindSig: empty left-hand side"
287 [v] -> return v
288 _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $
289 (PsErrMultipleNamesInStandaloneKindSignature vs)
290
291 mkTyFamInstEqn :: SrcSpan
292 -> HsOuterFamEqnTyVarBndrs GhcPs
293 -> LHsType GhcPs
294 -> LHsType GhcPs
295 -> [AddEpAnn]
296 -> P (LTyFamInstEqn GhcPs)
297 mkTyFamInstEqn loc bndrs lhs rhs anns
298 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
299 ; cs <- getCommentsFor loc
300 ; return (L (noAnnSrcSpan loc) $ FamEqn
301 { feqn_ext = EpAnn (spanAsAnchor loc) (anns `mappend` ann) cs
302 , feqn_tycon = tc
303 , feqn_bndrs = bndrs
304 , feqn_pats = tparams
305 , feqn_fixity = fixity
306 , feqn_rhs = rhs })}
307
308 mkDataFamInst :: SrcSpan
309 -> NewOrData
310 -> Maybe (LocatedP CType)
311 -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
312 , LHsType GhcPs)
313 -> Maybe (LHsKind GhcPs)
314 -> [LConDecl GhcPs]
315 -> Located (HsDeriving GhcPs)
316 -> [AddEpAnn]
317 -> P (LInstDecl GhcPs)
318 mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
319 ksig data_cons (L _ maybe_deriv) anns
320 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
321 ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan
322 ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments
323 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
324 ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl
325 (FamEqn { feqn_ext = anns'
326 , feqn_tycon = tc
327 , feqn_bndrs = bndrs
328 , feqn_pats = tparams
329 , feqn_fixity = fixity
330 , feqn_rhs = defn })))) }
331
332 mkTyFamInst :: SrcSpan
333 -> TyFamInstEqn GhcPs
334 -> [AddEpAnn]
335 -> P (LInstDecl GhcPs)
336 mkTyFamInst loc eqn anns = do
337 cs <- getCommentsFor loc
338 return (L (noAnnSrcSpan loc) (TyFamInstD noExtField
339 (TyFamInstDecl (EpAnn (spanAsAnchor loc) anns cs) eqn)))
340
341 mkFamDecl :: SrcSpan
342 -> FamilyInfo GhcPs
343 -> TopLevelFlag
344 -> LHsType GhcPs -- LHS
345 -> LFamilyResultSig GhcPs -- Optional result signature
346 -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation
347 -> [AddEpAnn]
348 -> P (LTyClDecl GhcPs)
349 mkFamDecl loc info topLevel lhs ksig injAnn annsIn
350 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
351 ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]
352 ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams
353 ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]
354 ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2)
355 ; return (L (noAnnSrcSpan loc) (FamDecl noExtField
356 (FamilyDecl
357 { fdExt = anns'
358 , fdTopLevel = topLevel
359 , fdInfo = info, fdLName = tc
360 , fdTyVars = tyvars
361 , fdFixity = fixity
362 , fdResultSig = ksig
363 , fdInjectivityAnn = injAnn }))) }
364 where
365 equals_or_where = case info of
366 DataFamily -> empty
367 OpenTypeFamily -> empty
368 ClosedTypeFamily {} -> whereDots
369
370 mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)
371 -- If the user wrote
372 -- [pads| ... ] then return a QuasiQuoteD
373 -- $(e) then return a SpliceD
374 -- but if they wrote, say,
375 -- f x then behave as if they'd written $(f x)
376 -- ie a SpliceD
377 --
378 -- Typed splices are not allowed at the top level, thus we do not represent them
379 -- as spliced declaration. See #10945
380 mkSpliceDecl lexpr@(L loc expr)
381 | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr = do
382 cs <- getCommentsFor (locA loc)
383 return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
384
385 | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr = do
386 cs <- getCommentsFor (locA loc)
387 return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
388
389 | otherwise = do
390 cs <- getCommentsFor (locA loc)
391 return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField
392 (L loc (mkUntypedSplice noAnn BareSplice lexpr))
393 ImplicitSplice)
394
395 mkRoleAnnotDecl :: SrcSpan
396 -> LocatedN RdrName -- type being annotated
397 -> [Located (Maybe FastString)] -- roles
398 -> [AddEpAnn]
399 -> P (LRoleAnnotDecl GhcPs)
400 mkRoleAnnotDecl loc tycon roles anns
401 = do { roles' <- mapM parse_role roles
402 ; cs <- getCommentsFor loc
403 ; return $ L (noAnnSrcSpan loc)
404 $ RoleAnnotDecl (EpAnn (spanAsAnchor loc) anns cs) tycon roles' }
405 where
406 role_data_type = dataTypeOf (undefined :: Role)
407 all_roles = map fromConstr $ dataTypeConstrs role_data_type
408 possible_roles = [(fsFromRole role, role) | role <- all_roles]
409
410 parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing
411 parse_role (L loc_role (Just role))
412 = case lookup role possible_roles of
413 Just found_role -> return $ L (noAnnSrcSpan loc_role) $ Just found_role
414 Nothing ->
415 let nearby = fuzzyLookup (unpackFS role)
416 (mapFst unpackFS possible_roles)
417 in
418 addFatalError $ mkPlainErrorMsgEnvelope loc_role $
419 (PsErrIllegalRoleName role nearby)
420
421 -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
422 -- binders without annotations. Only accepts specified variables, and errors if
423 -- any of the provided binders has an 'InferredSpec' annotation.
424 fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]
425 fromSpecTyVarBndrs = mapM fromSpecTyVarBndr
426
427 -- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without
428 -- annotations. Only accepts specified variables, and errors if the provided
429 -- binder has an 'InferredSpec' annotation.
430 fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
431 fromSpecTyVarBndr bndr = case bndr of
432 (L loc (UserTyVar xtv flag idp)) -> (check_spec flag loc)
433 >> return (L loc $ UserTyVar xtv () idp)
434 (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc)
435 >> return (L loc $ KindedTyVar xtv () idp k)
436 where
437 check_spec :: Specificity -> SrcSpanAnnA -> P ()
438 check_spec SpecifiedSpec _ = return ()
439 check_spec InferredSpec loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
440 PsErrInferredTypeVarNotAllowed
441
442 -- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@
443 annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs
444 -> (HsLocalBinds GhcPs, Maybe EpAnnComments)
445 annBinds a cs (HsValBinds an bs) = (HsValBinds (add_where a an cs) bs, Nothing)
446 annBinds a cs (HsIPBinds an bs) = (HsIPBinds (add_where a an cs) bs, Nothing)
447 annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs)
448
449 add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
450 add_where an@(AddEpAnn _ (EpaSpan rs)) (EpAnn a (AnnList anc o c r t) cs) cs2
451 | valid_anchor (anchor a)
452 = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2)
453 | otherwise
454 = EpAnn (patch_anchor rs a)
455 (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2)
456 add_where an@(AddEpAnn _ (EpaSpan rs)) EpAnnNotUsed cs
457 = EpAnn (Anchor rs UnchangedAnchor)
458 (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs
459 add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where"
460 -- EpaDelta should only be used for transformations
461
462 valid_anchor :: RealSrcSpan -> Bool
463 valid_anchor r = srcSpanStartLine r >= 0
464
465 -- If the decl list for where binds is empty, the anchor ends up
466 -- invalid. In this case, use the parent one
467 patch_anchor :: RealSrcSpan -> Anchor -> Anchor
468 patch_anchor r1 (Anchor r0 op) = Anchor r op
469 where
470 r = if srcSpanStartLine r0 < 0 then r1 else r0
471
472 {- **********************************************************************
473
474 #cvBinds-etc# Converting to @HsBinds@, etc.
475
476 ********************************************************************* -}
477
478 -- | Function definitions are restructured here. Each is assumed to be recursive
479 -- initially, and non recursive definitions are discovered by the dependency
480 -- analyser.
481
482
483 -- | Groups together bindings for a single function
484 cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
485 cvTopDecls decls = getMonoBindAll (fromOL decls)
486
487 -- Declaration list may only contain value bindings and signatures.
488 cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
489 cvBindGroup binding
490 = do { (mbs, sigs, fam_ds, tfam_insts
491 , dfam_insts, _) <- cvBindsAndSigs binding
492 ; massert (null fam_ds && null tfam_insts && null dfam_insts)
493 ; return $ ValBinds NoAnnSortKey mbs sigs }
494
495 cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
496 -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
497 , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
498 -- Input decls contain just value bindings and signatures
499 -- and in case of class or instance declarations also
500 -- associated type declarations. They might also contain Haddock comments.
501 cvBindsAndSigs fb = do
502 fb' <- drop_bad_decls (fromOL fb)
503 return (partitionBindsAndSigs (getMonoBindAll fb'))
504 where
505 -- cvBindsAndSigs is called in several places in the parser,
506 -- and its items can be produced by various productions:
507 --
508 -- * decl (when parsing a where clause or a let-expression)
509 -- * decl_inst (when parsing an instance declaration)
510 -- * decl_cls (when parsing a class declaration)
511 --
512 -- partitionBindsAndSigs can handle almost all declaration forms produced
513 -- by the aforementioned productions, except for SpliceD, which we filter
514 -- out here (in drop_bad_decls).
515 --
516 -- We're not concerned with every declaration form possible, such as those
517 -- produced by the topdecl parser production, because cvBindsAndSigs is not
518 -- called on top-level declarations.
519 drop_bad_decls [] = return []
520 drop_bad_decls (L l (SpliceD _ d) : ds) = do
521 addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d
522 drop_bad_decls ds
523 drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds
524
525 -----------------------------------------------------------------------------
526 -- Group function bindings into equation groups
527
528 getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
529 -> (LHsBind GhcPs, [LHsDecl GhcPs])
530 -- Suppose (b',ds') = getMonoBind b ds
531 -- ds is a list of parsed bindings
532 -- b is a MonoBinds that has just been read off the front
533
534 -- Then b' is the result of grouping more equations from ds that
535 -- belong with b into a single MonoBinds, and ds' is the depleted
536 -- list of parsed bindings.
537 --
538 -- All Haddock comments between equations inside the group are
539 -- discarded.
540 --
541 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
542
543 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
544 , fun_matches =
545 MG { mg_alts = (L _ m1@[L _ mtchs1]) } }))
546 binds
547 | has_args m1
548 = go [L (removeCommentsA loc1) mtchs1] (commentsOnlyA loc1) binds []
549 where
550 go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA
551 -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
552 -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ
553 go mtchs loc
554 ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)
555 , fun_matches =
556 MG { mg_alts = (L _ [L lm2 mtchs2]) } })))
557 : binds) _
558 | f1 == f2 =
559 let (loc2', lm2') = transferAnnsA loc2 lm2
560 in go (L lm2' mtchs2 : mtchs)
561 (combineSrcSpansA loc loc2') binds []
562 go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
563 = let doc_decls' = doc_decl : doc_decls
564 in go mtchs (combineSrcSpansA loc loc2) binds doc_decls'
565 go mtchs loc binds doc_decls
566 = ( L loc (makeFunBind fun_id1 (mkLocatedList $ reverse mtchs))
567 , (reverse doc_decls) ++ binds)
568 -- Reverse the final matches, to get it back in the right order
569 -- Do the same thing with the trailing doc comments
570
571 getMonoBind bind binds = (bind, binds)
572
573 -- Group together adjacent FunBinds for every function.
574 getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
575 getMonoBindAll [] = []
576 getMonoBindAll (L l (ValD _ b) : ds) =
577 let (L l' b', ds') = getMonoBind (L l b) ds
578 in L l' (ValD noExtField b') : getMonoBindAll ds'
579 getMonoBindAll (d : ds) = d : getMonoBindAll ds
580
581 has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
582 has_args [] = panic "GHC.Parser.PostProcess.has_args"
583 has_args (L _ (Match { m_pats = args }) : _) = not (null args)
584 -- Don't group together FunBinds if they have
585 -- no arguments. This is necessary now that variable bindings
586 -- with no arguments are now treated as FunBinds rather
587 -- than pattern bindings (tests/rename/should_fail/rnfail002).
588
589 {- **********************************************************************
590
591 #PrefixToHS-utils# Utilities for conversion
592
593 ********************************************************************* -}
594
595 {- Note [Parsing data constructors is hard]
596 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
597
598 The problem with parsing data constructors is that they look a lot like types.
599 Compare:
600
601 (s1) data T = C t1 t2
602 (s2) type T = C t1 t2
603
604 Syntactically, there's little difference between these declarations, except in
605 (s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.
606
607 This similarity would pose no problem if we knew ahead of time if we are
608 parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple
609 (but wrong!) rule comes to mind: in 'data' declarations assume we are parsing
610 data constructors, and in other contexts (e.g. 'type' declarations) assume we
611 are parsing type constructors.
612
613 This simple rule does not work because of two problematic cases:
614
615 (p1) data T = C t1 t2 :+ t3
616 (p2) data T = C t1 t2 => t3
617
618 In (p1) we encounter (:+) and it turns out we are parsing an infix data
619 declaration, so (C t1 t2) is a type and 'C' is a type constructor.
620 In (p2) we encounter (=>) and it turns out we are parsing an existential
621 context, so (C t1 t2) is a constraint and 'C' is a type constructor.
622
623 As the result, in order to determine whether (C t1 t2) declares a data
624 constructor, a type, or a context, we would need unlimited lookahead which
625 'happy' is not so happy with.
626 -}
627
628 -- | Reinterpret a type constructor, including type operators, as a data
629 -- constructor.
630 -- See Note [Parsing data constructors is hard]
631 tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
632 tyConToDataCon (L loc tc)
633 | isTcOcc occ || isDataOcc occ
634 , isLexCon (occNameFS occ)
635 = return (L loc (setRdrNameSpace tc srcDataName))
636
637 | otherwise
638 = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc)
639 where
640 occ = rdrNameOcc tc
641
642 mkPatSynMatchGroup :: LocatedN RdrName
643 -> LocatedL (OrdList (LHsDecl GhcPs))
644 -> P (MatchGroup GhcPs (LHsExpr GhcPs))
645 mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
646 do { matches <- mapM fromDecl (fromOL decls)
647 ; when (null matches) (wrongNumberErr (locA loc))
648 ; return $ mkMatchGroup FromSource (L ld matches) }
649 where
650 fromDecl (L loc decl@(ValD _ (PatBind _
651 -- AZ: where should these anns come from?
652 pat@(L _ (ConPat noAnn ln@(L _ name) details))
653 rhs _))) =
654 do { unless (name == patsyn_name) $
655 wrongNameBindingErr (locA loc) decl
656 ; match <- case details of
657 PrefixCon _ pats -> return $ Match { m_ext = noAnn
658 , m_ctxt = ctxt, m_pats = pats
659 , m_grhss = rhs }
660 where
661 ctxt = FunRhs { mc_fun = ln
662 , mc_fixity = Prefix
663 , mc_strictness = NoSrcStrict }
664
665 InfixCon p1 p2 -> return $ Match { m_ext = noAnn
666 , m_ctxt = ctxt
667 , m_pats = [p1, p2]
668 , m_grhss = rhs }
669 where
670 ctxt = FunRhs { mc_fun = ln
671 , mc_fixity = Infix
672 , mc_strictness = NoSrcStrict }
673
674 RecCon{} -> recordPatSynErr (locA loc) pat
675 ; return $ L loc match }
676 fromDecl (L loc decl) = extraDeclErr (locA loc) decl
677
678 extraDeclErr loc decl =
679 addFatalError $ mkPlainErrorMsgEnvelope loc $
680 (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl)
681
682 wrongNameBindingErr loc decl =
683 addFatalError $ mkPlainErrorMsgEnvelope loc $
684 (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl)
685
686 wrongNumberErr loc =
687 addFatalError $ mkPlainErrorMsgEnvelope loc $
688 (PsErrEmptyWhereInPatSynDecl patsyn_name)
689
690 recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
691 recordPatSynErr loc pat =
692 addFatalError $ mkPlainErrorMsgEnvelope loc $
693 (PsErrRecordSyntaxInPatSynDecl pat)
694
695 mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
696 -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs
697 -> ConDecl GhcPs
698
699 mkConDeclH98 ann name mb_forall mb_cxt args
700 = ConDeclH98 { con_ext = ann
701 , con_name = name
702 , con_forall = isJust mb_forall
703 , con_ex_tvs = mb_forall `orElse` []
704 , con_mb_cxt = mb_cxt
705 , con_args = args
706 , con_doc = Nothing }
707
708 -- | Construct a GADT-style data constructor from the constructor names and
709 -- their type. Some interesting aspects of this function:
710 --
711 -- * This splits up the constructor type into its quantified type variables (if
712 -- provided), context (if provided), argument types, and result type, and
713 -- records whether this is a prefix or record GADT constructor. See
714 -- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.
715 mkGadtDecl :: SrcSpan
716 -> [LocatedN RdrName]
717 -> LHsSigType GhcPs
718 -> [AddEpAnn]
719 -> P (LConDecl GhcPs)
720 mkGadtDecl loc names ty annsIn = do
721 cs <- getCommentsFor loc
722 let l = noAnnSrcSpan loc
723
724 (args, res_ty, annsa, csa) <-
725 case body_ty of
726 L ll (HsFunTy af hsArr (L loc' (HsRecTy an rf)) res_ty) -> do
727 let an' = addCommentsToEpAnn (locA loc') an (comments af)
728 arr <- case hsArr of
729 HsUnrestrictedArrow arr -> return arr
730 _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $
731 (PsErrIllegalGadtRecordMultiplicity hsArr)
732 return noHsUniTok
733
734 return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf) arr, res_ty
735 , [], epAnnComments (ann ll))
736 _ -> do
737 let (anns, cs, arg_types, res_type) = splitHsFunType body_ty
738 return (PrefixConGADT arg_types, res_type, anns, cs)
739
740 let an = case outer_bndrs of
741 _ -> EpAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa)
742
743 pure $ L l ConDeclGADT
744 { con_g_ext = an
745 , con_names = names
746 , con_bndrs = L (getLoc ty) outer_bndrs
747 , con_mb_cxt = mcxt
748 , con_g_args = args
749 , con_res_ty = res_ty
750 , con_doc = Nothing }
751 where
752 (outer_bndrs, mcxt, body_ty) = splitLHsGadtTy ty
753
754 setRdrNameSpace :: RdrName -> NameSpace -> RdrName
755 -- ^ This rather gruesome function is used mainly by the parser.
756 -- When parsing:
757 --
758 -- > data T a = T | T1 Int
759 --
760 -- we parse the data constructors as /types/ because of parser ambiguities,
761 -- so then we need to change the /type constr/ to a /data constr/
762 --
763 -- The exact-name case /can/ occur when parsing:
764 --
765 -- > data [] a = [] | a : [a]
766 --
767 -- For the exact-name case we return an original name.
768 setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
769 setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
770 setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
771 setRdrNameSpace (Exact n) ns
772 | Just thing <- wiredInNameTyThing_maybe n
773 = setWiredInNameSpace thing ns
774 -- Preserve Exact Names for wired-in things,
775 -- notably tuples and lists
776
777 | isExternalName n
778 = Orig (nameModule n) occ
779
780 | otherwise -- This can happen when quoting and then
781 -- splicing a fixity declaration for a type
782 = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
783 where
784 occ = setOccNameSpace ns (nameOccName n)
785
786 setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
787 setWiredInNameSpace (ATyCon tc) ns
788 | isDataConNameSpace ns
789 = ty_con_data_con tc
790 | isTcClsNameSpace ns
791 = Exact (getName tc) -- No-op
792
793 setWiredInNameSpace (AConLike (RealDataCon dc)) ns
794 | isTcClsNameSpace ns
795 = data_con_ty_con dc
796 | isDataConNameSpace ns
797 = Exact (getName dc) -- No-op
798
799 setWiredInNameSpace thing ns
800 = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)
801
802 ty_con_data_con :: TyCon -> RdrName
803 ty_con_data_con tc
804 | isTupleTyCon tc
805 , Just dc <- tyConSingleDataCon_maybe tc
806 = Exact (getName dc)
807
808 | tc `hasKey` listTyConKey
809 = Exact nilDataConName
810
811 | otherwise -- See Note [setRdrNameSpace for wired-in names]
812 = Unqual (setOccNameSpace srcDataName (getOccName tc))
813
814 data_con_ty_con :: DataCon -> RdrName
815 data_con_ty_con dc
816 | let tc = dataConTyCon dc
817 , isTupleTyCon tc
818 = Exact (getName tc)
819
820 | dc `hasKey` nilDataConKey
821 = Exact listTyConName
822
823 | otherwise -- See Note [setRdrNameSpace for wired-in names]
824 = Unqual (setOccNameSpace tcClsName (getOccName dc))
825
826
827
828 {- Note [setRdrNameSpace for wired-in names]
829 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
830 In GHC.Types, which declares (:), we have
831 infixr 5 :
832 The ambiguity about which ":" is meant is resolved by parsing it as a
833 data constructor, but then using dataTcOccs to try the type constructor too;
834 and that in turn calls setRdrNameSpace to change the name-space of ":" to
835 tcClsName. There isn't a corresponding ":" type constructor, but it's painful
836 to make setRdrNameSpace partial, so we just make an Unqual name instead. It
837 really doesn't matter!
838 -}
839
840 eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a
841 -- Adapts the Either monad to the P monad
842 eitherToP (Left err) = addFatalError err
843 eitherToP (Right thing) = return thing
844
845 checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs]
846 -> P (LHsQTyVars GhcPs) -- the synthesized type variables
847 -- ^ Check whether the given list of type parameters are all type variables
848 -- (possibly with a kind signature).
849 checkTyVars pp_what equals_or_where tc tparms
850 = do { tvs <- mapM check tparms
851 ; return (mkHsQTvs tvs) }
852 where
853 check (HsTypeArg _ ki@(L loc _)) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
854 (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc))
855 check (HsValArg ty) = chkParens [] [] emptyComments ty
856 check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $
857 (PsErrMalformedDecl pp_what (unLoc tc))
858 -- Keep around an action for adjusting the annotations of extra parens
859 chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs
860 -> P (LHsTyVarBndr () GhcPs)
861 chkParens ops cps cs (L l (HsParTy an ty))
862 = let
863 (o,c) = mkParensEpAnn (realSrcSpan $ locA l)
864 in
865 chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) ty
866 chkParens ops cps cs ty = chk ops cps cs ty
867
868 -- Check that the name space is correct!
869 chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
870 chk ops cps cs (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k))
871 | isRdrTyVar tv
872 = let
873 an = (reverse ops) ++ cps
874 in
875 return (L (widenLocatedAn (l Semi.<> annt) an)
876 (KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k))
877 chk ops cps cs (L l (HsTyVar ann _ (L ltv tv)))
878 | isRdrTyVar tv
879 = let
880 an = (reverse ops) ++ cps
881 in
882 return (L (widenLocatedAn l an)
883 (UserTyVar (addAnns ann an cs) () (L ltv tv)))
884 chk _ _ _ t@(L loc _)
885 = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
886 (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)
887
888
889 whereDots, equalsDots :: SDoc
890 -- Second argument to checkTyVars
891 whereDots = text "where ..."
892 equalsDots = text "= ..."
893
894 checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
895 checkDatatypeContext Nothing = return ()
896 checkDatatypeContext (Just c)
897 = do allowed <- getBit DatatypeContextsBit
898 unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $
899 (PsErrIllegalDataTypeContext c)
900
901 type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar
902 data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs))
903 -- ^ Essentially a wrapper for a @RuleBndr GhcPs@
904
905 -- turns RuleTyTmVars into RuleBnrs - this is straightforward
906 mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
907 mkRuleBndrs = fmap (fmap cvt_one)
908 where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v
909 cvt_one (RuleTyTmVar ann v (Just sig)) =
910 RuleBndrSig ann v (mkHsPatSigType noAnn sig)
911
912 -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
913 mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
914 mkRuleTyVarBndrs = fmap cvt_one
915 where cvt_one (L l (RuleTyTmVar ann v Nothing))
916 = L (l2l l) (UserTyVar ann () (fmap tm_to_ty v))
917 cvt_one (L l (RuleTyTmVar ann v (Just sig)))
918 = L (l2l l) (KindedTyVar ann () (fmap tm_to_ty v) sig)
919 -- takes something in namespace 'varName' to something in namespace 'tvName'
920 tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)
921 tm_to_ty _ = panic "mkRuleTyVarBndrs"
922
923 -- See note [Parsing explicit foralls in Rules] in Parser.y
924 checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
925 checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
926 where check (L loc (Unqual occ)) =
927 -- TODO: don't use string here, OccName has a Unique/FastString
928 when ((occNameString occ ==) `any` ["forall","family","role"])
929 (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
930 (PsErrParseErrorOnInput occ))
931 check _ = panic "checkRuleTyVarBndrNames"
932
933 checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)
934 checkRecordSyntax lr@(L loc r)
935 = do allowed <- getBit TraditionalRecordSyntaxBit
936 unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $
937 (PsErrIllegalTraditionalRecordSyntax (ppr r))
938 return lr
939
940 -- | Check if the gadt_constrlist is empty. Only raise parse error for
941 -- `data T where` to avoid affecting existing error message, see #8258.
942 checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])
943 -> P (Located ([AddEpAnn], [LConDecl GhcPs]))
944 checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration.
945 = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax
946 unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $
947 PsErrIllegalWhereInDataDecl
948 return gadts
949 checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration.
950
951 checkTyClHdr :: Bool -- True <=> class header
952 -- False <=> type header
953 -> LHsType GhcPs
954 -> P (LocatedN RdrName, -- the head symbol (type or class name)
955 [LHsTypeArg GhcPs], -- parameters of head symbol
956 LexicalFixity, -- the declaration is in infix format
957 [AddEpAnn]) -- API Annotation for HsParTy
958 -- when stripping parens
959 -- Well-formedness check and decomposition of type and class heads.
960 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
961 -- Int :*: Bool into (:*:, [Int, Bool])
962 -- returning the pieces
963 checkTyClHdr is_cls ty
964 = goL ty [] [] [] Prefix
965 where
966 goL (L l ty) acc ops cps fix = go (locA l) ty acc ops cps fix
967
968 -- workaround to define '*' despite StarIsType
969 go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
970 = do { addPsMessage (locA l) PsWarnStarBinder
971 ; let name = mkOccName tcClsName (starSym isUni)
972 ; let a' = newAnns l an
973 ; return (L a' (Unqual name), acc, fix
974 , (reverse ops') ++ cps') }
975
976 go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
977 | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps)
978 go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ops cps _fix
979 | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps)
980 go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
981 where
982 (o,c) = mkParensEpAnn (realSrcSpan l)
983 go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix
984 go _ (HsAppKindTy l ty ki) acc ops cps fix = goL ty (HsTypeArg l ki:acc) ops cps fix
985 go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
986 = return (L (noAnnSrcSpan l) (nameRdrName tup_name)
987 , map HsValArg ts, fix, (reverse ops)++cps)
988 where
989 arity = length ts
990 tup_name | is_cls = cTupleTyConName arity
991 | otherwise = getName (tupleTyCon Boxed arity)
992 -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?)
993 go l _ _ _ _ _
994 = addFatalError $ mkPlainErrorMsgEnvelope l $
995 (PsErrMalformedTyOrClDecl ty)
996
997 -- Combine the annotations from the HsParTy and HsStarTy into a
998 -- new one for the LocatedN RdrName
999 newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN
1000 newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =
1001 let
1002 lr = combineRealSrcSpans (realSrcSpan l) (anchor as)
1003 -- lr = widenAnchorR as (realSrcSpan l)
1004 an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs)
1005 in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
1006 newAnns _ EpAnnNotUsed = panic "missing AnnParen"
1007 newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =
1008 let
1009 lr = combineRealSrcSpans (anchor ap) (anchor as)
1010 an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs))
1011 in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
1012
1013 -- | Yield a parse error if we have a function applied directly to a do block
1014 -- etc. and BlockArguments is not enabled.
1015 checkExpBlockArguments :: LHsExpr GhcPs -> PV ()
1016 checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
1017 (checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
1018 where
1019 checkExpr :: LHsExpr GhcPs -> PV ()
1020 checkExpr expr = case unLoc expr of
1021 HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr
1022 HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr
1023 HsLam {} -> check PsErrLambdaInFunAppExpr expr
1024 HsCase {} -> check PsErrCaseInFunAppExpr expr
1025 HsLamCase {} -> check PsErrLambdaCaseInFunAppExpr expr
1026 HsLet {} -> check PsErrLetInFunAppExpr expr
1027 HsIf {} -> check PsErrIfInFunAppExpr expr
1028 HsProc {} -> check PsErrProcInFunAppExpr expr
1029 _ -> return ()
1030
1031 checkCmd :: LHsCmd GhcPs -> PV ()
1032 checkCmd cmd = case unLoc cmd of
1033 HsCmdLam {} -> check PsErrLambdaCmdInFunAppCmd cmd
1034 HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd
1035 HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd
1036 HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd
1037 HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd
1038 _ -> return ()
1039
1040 check err a = do
1041 blockArguments <- getBit BlockArgumentsBit
1042 unless blockArguments $
1043 addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a)
1044
1045 -- | Validate the context constraints and break up a context into a list
1046 -- of predicates.
1047 --
1048 -- @
1049 -- (Eq a, Ord b) --> [Eq a, Ord b]
1050 -- Eq a --> [Eq a]
1051 -- (Eq a) --> [Eq a]
1052 -- (((Eq a))) --> [Eq a]
1053 -- @
1054 checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
1055 checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) =
1056 check ([],[],emptyComments) orig_t
1057 where
1058 check :: ([EpaLocation],[EpaLocation],EpAnnComments)
1059 -> LHsType GhcPs -> P (LHsContext GhcPs)
1060 check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts))
1061 -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
1062 -- be used as context constraints.
1063 -- Ditto ()
1064 = do
1065 let (op,cp,cs') = case ann' of
1066 EpAnnNotUsed -> ([],[],emptyComments)
1067 EpAnn _ (AnnParen _ o c) cs -> ([o],[c],cs)
1068 return (L (SrcSpanAnn (EpAnn (spanAsAnchor l)
1069 -- Append parens so that the original order in the source is maintained
1070 (AnnContext Nothing (oparens ++ op) (cp ++ cparens)) (cs Semi.<> cs')) l) ts)
1071
1072 check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty))
1073 -- to be sure HsParTy doesn't get into the way
1074 = do
1075 let (op,cp,cs') = case ann' of
1076 EpAnnNotUsed -> ([],[],emptyComments)
1077 EpAnn _ (AnnParen _ open close ) cs -> ([open],[close],cs)
1078 check (op++opi,cp++cpi,cs' Semi.<> csi) ty
1079
1080 -- No need for anns, returning original
1081 check (_opi,_cpi,_csi) _t =
1082 return (L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext Nothing [] []) emptyComments) l) [orig_t])
1083
1084 checkImportDecl :: Maybe EpaLocation
1085 -> Maybe EpaLocation
1086 -> P ()
1087 checkImportDecl mPre mPost = do
1088 let whenJust mg f = maybe (pure ()) f mg
1089
1090 importQualifiedPostEnabled <- getBit ImportQualifiedPostBit
1091
1092 -- Error if 'qualified' found in postpositive position and
1093 -- 'ImportQualifiedPost' is not in effect.
1094 whenJust mPost $ \post ->
1095 when (not importQualifiedPostEnabled) $
1096 failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)
1097
1098 -- Error if 'qualified' occurs in both pre and postpositive
1099 -- positions.
1100 whenJust mPost $ \post ->
1101 when (isJust mPre) $
1102 failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)
1103
1104 -- Warn if 'qualified' found in prepositive position and
1105 -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.
1106 whenJust mPre $ \pre ->
1107 warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Strict.Nothing)
1108
1109 -- -------------------------------------------------------------------------
1110 -- Checking Patterns.
1111
1112 -- We parse patterns as expressions and check for valid patterns below,
1113 -- converting the expression into a pattern at the same time.
1114
1115 checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
1116 checkPattern = runPV . checkLPat
1117
1118 checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
1119 checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)
1120
1121 checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
1122 checkLPat e@(L l _) = checkPat l e [] []
1123
1124 checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs]
1125 -> PV (LPat GhcPs)
1126 checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
1127 | isRdrDataCon c = return . L loc $ ConPat
1128 { pat_con_ext = noAnn -- AZ: where should this come from?
1129 , pat_con = L ln c
1130 , pat_args = PrefixCon tyargs args
1131 }
1132 | not (null tyargs) =
1133 patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs
1134 | (not (null args) && patIsRec c) = do
1135 ctx <- askParseContext
1136 patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx
1137 checkPat loc (L _ (PatBuilderAppType f t)) tyargs args =
1138 checkPat loc f (t : tyargs) args
1139 checkPat loc (L _ (PatBuilderApp f e)) [] args = do
1140 p <- checkLPat e
1141 checkPat loc f [] (p : args)
1142 checkPat loc (L l e) [] [] = do
1143 p <- checkAPat loc e
1144 return (L l p)
1145 checkPat loc e _ _ = do
1146 details <- fromParseContext <$> askParseContext
1147 patFail (locA loc) (PsErrInPat (unLoc e) details)
1148
1149 checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
1150 checkAPat loc e0 = do
1151 nPlusKPatterns <- getBit NPlusKPatternsBit
1152 case e0 of
1153 PatBuilderPat p -> return p
1154 PatBuilderVar x -> return (VarPat noExtField x)
1155
1156 -- Overloaded numeric patterns (e.g. f 0 x = x)
1157 -- Negation is recorded separately, so that the literal is zero or +ve
1158 -- NB. Negative *primitive* literals are already handled by the lexer
1159 PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn)
1160
1161 -- n+k patterns
1162 PatBuilderOpApp
1163 (L _ (PatBuilderVar (L nloc n)))
1164 (L l plus)
1165 (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
1166 (EpAnn anc _ cs)
1167 | nPlusKPatterns && (plus == plus_RDR)
1168 -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit)
1169 (EpAnn anc (epaLocationFromSrcAnn l) cs))
1170
1171 -- Improve error messages for the @-operator when the user meant an @-pattern
1172 PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do
1173 addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos
1174 return (WildPat noExtField)
1175
1176 PatBuilderOpApp l (L cl c) r anns
1177 | isRdrDataCon c -> do
1178 l <- checkLPat l
1179 r <- checkLPat r
1180 return $ ConPat
1181 { pat_con_ext = anns
1182 , pat_con = L cl c
1183 , pat_args = InfixCon l r
1184 }
1185
1186 PatBuilderPar lpar e rpar -> do
1187 p <- checkLPat e
1188 return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar)
1189
1190 _ -> do
1191 details <- fromParseContext <$> askParseContext
1192 patFail (locA loc) (PsErrInPat e0 details)
1193
1194 placeHolderPunRhs :: DisambECP b => PV (LocatedA b)
1195 -- The RHS of a punned record field will be filled in by the renamer
1196 -- It's better not to make it an error, in case we want to print it when
1197 -- debugging
1198 placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR)
1199
1200 plus_RDR, pun_RDR :: RdrName
1201 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
1202 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
1203
1204 checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))
1205 -> PV (LHsRecField GhcPs (LPat GhcPs))
1206 checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld)
1207 return (L l (fld { hfbRHS = p }))
1208
1209 patFail :: SrcSpan -> PsMessage -> PV a
1210 patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg
1211
1212 patIsRec :: RdrName -> Bool
1213 patIsRec e = e == mkUnqual varName (fsLit "rec")
1214
1215 ---------------------------------------------------------------------------
1216 -- Check Equation Syntax
1217
1218 checkValDef :: SrcSpan
1219 -> LocatedA (PatBuilder GhcPs)
1220 -> Maybe (AddEpAnn, LHsType GhcPs)
1221 -> Located (GRHSs GhcPs (LHsExpr GhcPs))
1222 -> P (HsBind GhcPs)
1223
1224 checkValDef loc lhs (Just (sigAnn, sig)) grhss
1225 -- x :: ty = rhs parses as a *pattern* binding
1226 = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig [sigAnn]
1227 >>= checkLPat
1228 checkPatBind loc [] lhs' grhss
1229
1230 checkValDef loc lhs Nothing g
1231 = do { mb_fun <- isFunLhs lhs
1232 ; case mb_fun of
1233 Just (fun, is_infix, pats, ann) ->
1234 checkFunBind NoSrcStrict loc ann
1235 fun is_infix pats g
1236 Nothing -> do
1237 lhs' <- checkPattern lhs
1238 checkPatBind loc [] lhs' g }
1239
1240 checkFunBind :: SrcStrictness
1241 -> SrcSpan
1242 -> [AddEpAnn]
1243 -> LocatedN RdrName
1244 -> LexicalFixity
1245 -> [LocatedA (PatBuilder GhcPs)]
1246 -> Located (GRHSs GhcPs (LHsExpr GhcPs))
1247 -> P (HsBind GhcPs)
1248 checkFunBind strictness locF ann fun is_infix pats (L _ grhss)
1249 = do ps <- runPV_details extraDetails (mapM checkLPat pats)
1250 let match_span = noAnnSrcSpan $ locF
1251 cs <- getCommentsFor locF
1252 return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)
1253 [L match_span (Match { m_ext = EpAnn (spanAsAnchor locF) ann cs
1254 , m_ctxt = FunRhs
1255 { mc_fun = fun
1256 , mc_fixity = is_infix
1257 , mc_strictness = strictness }
1258 , m_pats = ps
1259 , m_grhss = grhss })]))
1260 -- The span of the match covers the entire equation.
1261 -- That isn't quite right, but it'll do for now.
1262 where
1263 extraDetails
1264 | Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock
1265 | otherwise = noParseContext
1266
1267 makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
1268 -> HsBind GhcPs
1269 -- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too
1270 makeFunBind fn ms
1271 = FunBind { fun_ext = noExtField,
1272 fun_id = fn,
1273 fun_matches = mkMatchGroup FromSource ms,
1274 fun_tick = [] }
1275
1276 -- See Note [FunBind vs PatBind]
1277 checkPatBind :: SrcSpan
1278 -> [AddEpAnn]
1279 -> LPat GhcPs
1280 -> Located (GRHSs GhcPs (LHsExpr GhcPs))
1281 -> P (HsBind GhcPs)
1282 checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v))))
1283 (L _match_span grhss)
1284 = return (makeFunBind v (L (noAnnSrcSpan loc)
1285 [L (noAnnSrcSpan loc) (m (EpAnn (spanAsAnchor loc) (ans++annsIn) cs) v)]))
1286 where
1287 m a v = Match { m_ext = a
1288 , m_ctxt = FunRhs { mc_fun = v
1289 , mc_fixity = Prefix
1290 , mc_strictness = SrcStrict }
1291 , m_pats = []
1292 , m_grhss = grhss }
1293
1294 checkPatBind loc annsIn lhs (L _ grhss) = do
1295 cs <- getCommentsFor loc
1296 return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss ([],[]))
1297
1298 checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
1299 checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
1300 | isUnqual v
1301 , not (isDataOcc (rdrNameOcc v))
1302 = return lrdr
1303
1304 checkValSigLhs lhs@(L l _)
1305 = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrInvalidTypeSignature lhs
1306
1307 checkDoAndIfThenElse
1308 :: (Outputable a, Outputable b, Outputable c)
1309 => (a -> Bool -> b -> Bool -> c -> PsMessage)
1310 -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()
1311 checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr
1312 | semiThen || semiElse = do
1313 doAndIfThenElse <- getBit DoAndIfThenElseBit
1314 let e = err (unLoc guardExpr)
1315 semiThen (unLoc thenExpr)
1316 semiElse (unLoc elseExpr)
1317 loc = combineLocs (reLoc guardExpr) (reLoc elseExpr)
1318
1319 unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e)
1320 | otherwise = return ()
1321
1322 isFunLhs :: LocatedA (PatBuilder GhcPs)
1323 -> P (Maybe (LocatedN RdrName, LexicalFixity,
1324 [LocatedA (PatBuilder GhcPs)],[AddEpAnn]))
1325 -- A variable binding is parsed as a FunBind.
1326 -- Just (fun, is_infix, arg_pats) if e is a function LHS
1327 isFunLhs e = go e [] [] []
1328 where
1329 go (L _ (PatBuilderVar (L loc f))) es ops cps
1330 | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps))
1331 go (L _ (PatBuilderApp f e)) es ops cps = go f (e:es) ops cps
1332 go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps
1333 = let
1334 (o,c) = mkParensEpAnn (realSrcSpan $ locA l)
1335 in
1336 go e es (o:ops) (c:cps)
1337 go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ops cps
1338 | not (isRdrDataCon op) -- We have found the function!
1339 = return (Just (L loc' op, Infix, (l:r:es), (anns ++ reverse ops ++ cps)))
1340 | otherwise -- Infix data con; keep going
1341 = do { mb_l <- go l es ops cps
1342 ; case mb_l of
1343 Just (op', Infix, j : k : es', anns')
1344 -> return (Just (op', Infix, j : op_app : es', anns'))
1345 where
1346 op_app = L loc (PatBuilderOpApp k
1347 (L loc' op) r (EpAnn loca (reverse ops++cps) cs))
1348 _ -> return Nothing }
1349 go _ _ _ _ = return Nothing
1350
1351 mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
1352 mkBangTy anns strictness =
1353 HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness)
1354
1355 -- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.
1356 data UnpackednessPragma =
1357 UnpackednessPragma [AddEpAnn] SourceText SrcUnpackedness
1358
1359 -- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.
1360 addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)
1361 addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do
1362 let l' = combineSrcSpans lprag (getLocA ty)
1363 cs <- getCommentsFor l'
1364 let an = EpAnn (spanAsAnchor l') anns cs
1365 t' = addUnpackedness an ty
1366 return (L (noAnnSrcSpan l') t')
1367 where
1368 -- If we have a HsBangTy that only has a strictness annotation,
1369 -- such as ~T or !T, then add the pragma to the existing HsBangTy.
1370 --
1371 -- Otherwise, wrap the type in a new HsBangTy constructor.
1372 addUnpackedness an (L _ (HsBangTy x bang t))
1373 | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang
1374 = HsBangTy (addAnns an (epAnnAnns x) (epAnnComments x)) (HsSrcBang prag unpk strictness) t
1375 addUnpackedness an t
1376 = HsBangTy an (HsSrcBang prag unpk NoSrcStrict) t
1377
1378 ---------------------------------------------------------------------------
1379 -- | Check for monad comprehensions
1380 --
1381 -- If the flag MonadComprehensions is set, return a 'MonadComp' context,
1382 -- otherwise use the usual 'ListComp' context
1383
1384 checkMonadComp :: PV HsDoFlavour
1385 checkMonadComp = do
1386 monadComprehensions <- getBit MonadComprehensionsBit
1387 return $ if monadComprehensions
1388 then MonadComp
1389 else ListComp
1390
1391 -- -------------------------------------------------------------------------
1392 -- Expression/command/pattern ambiguity.
1393 -- See Note [Ambiguous syntactic categories]
1394 --
1395
1396 -- See Note [Ambiguous syntactic categories]
1397 --
1398 -- This newtype is required to avoid impredicative types in monadic
1399 -- productions. That is, in a production that looks like
1400 --
1401 -- | ... {% return (ECP ...) }
1402 --
1403 -- we are dealing with
1404 -- P ECP
1405 -- whereas without a newtype we would be dealing with
1406 -- P (forall b. DisambECP b => PV (Located b))
1407 --
1408 newtype ECP =
1409 ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) }
1410
1411 ecpFromExp :: LHsExpr GhcPs -> ECP
1412 ecpFromExp a = ECP (ecpFromExp' a)
1413
1414 ecpFromCmd :: LHsCmd GhcPs -> ECP
1415 ecpFromCmd a = ECP (ecpFromCmd' a)
1416
1417 -- The 'fbinds' parser rule produces values of this type. See Note
1418 -- [RecordDotSyntax field updates].
1419 type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))
1420
1421 -- | Disambiguate infix operators.
1422 -- See Note [Ambiguous syntactic categories]
1423 class DisambInfixOp b where
1424 mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b)
1425 mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b)
1426 mkHsInfixHolePV :: SrcSpan -> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located b)
1427
1428 instance DisambInfixOp (HsExpr GhcPs) where
1429 mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)
1430 mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)
1431 mkHsInfixHolePV l ann = do
1432 cs <- getCommentsFor l
1433 return $ L l (hsHoleExpr (ann cs))
1434
1435 instance DisambInfixOp RdrName where
1436 mkHsConOpPV (L l v) = return $ L l v
1437 mkHsVarOpPV (L l v) = return $ L l v
1438 mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole
1439
1440 type AnnoBody b
1441 = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcAnn NoEpAnns
1442 , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL
1443 , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA
1444 , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA
1445 , Anno [LocatedA (StmtLR GhcPs GhcPs
1446 (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnL
1447 )
1448
1449 -- | Disambiguate constructs that may appear when we do not know ahead of time whether we are
1450 -- parsing an expression, a command, or a pattern.
1451 -- See Note [Ambiguous syntactic categories]
1452 class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
1453 -- | See Note [Body in DisambECP]
1454 type Body b :: Type -> Type
1455 -- | Return a command without ambiguity, or fail in a non-command context.
1456 ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)
1457 -- | Return an expression without ambiguity, or fail in a non-expression context.
1458 ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)
1459 mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
1460 -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))
1461 -- | Disambiguate "\... -> ..." (lambda)
1462 mkHsLamPV
1463 :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b)
1464 -- | Disambiguate "let ... in ..."
1465 mkHsLetPV
1466 :: SrcSpan
1467 -> LHsToken "let" GhcPs
1468 -> HsLocalBinds GhcPs
1469 -> LHsToken "in" GhcPs
1470 -> LocatedA b
1471 -> PV (LocatedA b)
1472 -- | Infix operator representation
1473 type InfixOp b
1474 -- | Bring superclass constraints on InfixOp into scope.
1475 -- See Note [UndecidableSuperClasses for associated types]
1476 superInfixOp
1477 :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b)
1478 -- | Disambiguate "f # x" (infix operator)
1479 mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b
1480 -> PV (LocatedA b)
1481 -- | Disambiguate "case ... of ..."
1482 mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])
1483 -> EpAnnHsCase -> PV (LocatedA b)
1484 mkHsLamCasePV :: SrcSpan -> (LocatedL [LMatch GhcPs (LocatedA b)])
1485 -> [AddEpAnn]
1486 -> PV (LocatedA b)
1487 -- | Function argument representation
1488 type FunArg b
1489 -- | Bring superclass constraints on FunArg into scope.
1490 -- See Note [UndecidableSuperClasses for associated types]
1491 superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b)
1492 -- | Disambiguate "f x" (function application)
1493 mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b)
1494 -- | Disambiguate "f @t" (visible type application)
1495 mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b)
1496 -- | Disambiguate "if ... then ... else ..."
1497 mkHsIfPV :: SrcSpan
1498 -> LHsExpr GhcPs
1499 -> Bool -- semicolon?
1500 -> LocatedA b
1501 -> Bool -- semicolon?
1502 -> LocatedA b
1503 -> AnnsIf
1504 -> PV (LocatedA b)
1505 -- | Disambiguate "do { ... }" (do notation)
1506 mkHsDoPV ::
1507 SrcSpan ->
1508 Maybe ModuleName ->
1509 LocatedL [LStmt GhcPs (LocatedA b)] ->
1510 AnnList ->
1511 PV (LocatedA b)
1512 -- | Disambiguate "( ... )" (parentheses)
1513 mkHsParPV :: SrcSpan -> LHsToken "(" GhcPs -> LocatedA b -> LHsToken ")" GhcPs -> PV (LocatedA b)
1514 -- | Disambiguate a variable "f" or a data constructor "MkF".
1515 mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b)
1516 -- | Disambiguate a monomorphic literal
1517 mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)
1518 -- | Disambiguate an overloaded literal
1519 mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b)
1520 -- | Disambiguate a wildcard
1521 mkHsWildCardPV :: SrcSpan -> PV (Located b)
1522 -- | Disambiguate "a :: t" (type annotation)
1523 mkHsTySigPV
1524 :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b)
1525 -- | Disambiguate "[a,b,c]" (list syntax)
1526 mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b)
1527 -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)
1528 mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b)
1529 -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)
1530 mkHsRecordPV ::
1531 Bool -> -- Is OverloadedRecordUpdate in effect?
1532 SrcSpan ->
1533 SrcSpan ->
1534 LocatedA b ->
1535 ([Fbind b], Maybe SrcSpan) ->
1536 [AddEpAnn] ->
1537 PV (LocatedA b)
1538 -- | Disambiguate "-a" (negation)
1539 mkHsNegAppPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)
1540 -- | Disambiguate "(# a)" (right operator section)
1541 mkHsSectionR_PV
1542 :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (Located b)
1543 -- | Disambiguate "(a -> b)" (view pattern)
1544 mkHsViewPatPV
1545 :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)
1546 -- | Disambiguate "a@b" (as-pattern)
1547 mkHsAsPatPV
1548 :: SrcSpan -> LocatedN RdrName -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)
1549 -- | Disambiguate "~a" (lazy pattern)
1550 mkHsLazyPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)
1551 -- | Disambiguate "!a" (bang pattern)
1552 mkHsBangPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)
1553 -- | Disambiguate tuple sections and unboxed sums
1554 mkSumOrTuplePV
1555 :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddEpAnn] -> PV (LocatedA b)
1556 -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas
1557 rejectPragmaPV :: LocatedA b -> PV ()
1558
1559 {- Note [UndecidableSuperClasses for associated types]
1560 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1561 (This Note is about the code in GHC, not about the user code that we are parsing)
1562
1563 Assume we have a class C with an associated type T:
1564
1565 class C a where
1566 type T a
1567 ...
1568
1569 If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses:
1570
1571 {-# LANGUAGE UndecidableSuperClasses #-}
1572 class C (T a) => C a where
1573 type T a
1574 ...
1575
1576 Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes
1577 making GHC loop. The workaround is to bring this constraint into scope
1578 manually with a helper method:
1579
1580 class C a where
1581 type T a
1582 superT :: (C (T a) => r) -> r
1583
1584 In order to avoid ambiguous types, 'r' must mention 'a'.
1585
1586 For consistency, we use this approach for all constraints on associated types,
1587 even when -XUndecidableSuperClasses are not required.
1588 -}
1589
1590 {- Note [Body in DisambECP]
1591 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1592 There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that
1593 require their argument to take a form of (body GhcPs) for some (body :: Type ->
1594 *). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the
1595 superclass constraints of DisambECP.
1596
1597 The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop
1598 this requirement. It is possible and would allow removing the type index of
1599 PatBuilder, but leads to worse type inference, breaking some code in the
1600 typechecker.
1601 -}
1602
1603 instance DisambECP (HsCmd GhcPs) where
1604 type Body (HsCmd GhcPs) = HsCmd
1605 ecpFromCmd' = return
1606 ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)
1607 mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $
1608 PsErrOverloadedRecordDotInvalid
1609 mkHsLamPV l mg = do
1610 cs <- getCommentsFor l
1611 return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs))
1612 mkHsLetPV l tkLet bs tkIn e = do
1613 cs <- getCommentsFor l
1614 return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn e)
1615 type InfixOp (HsCmd GhcPs) = HsExpr GhcPs
1616 superInfixOp m = m
1617 mkHsOpAppPV l c1 op c2 = do
1618 let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c
1619 cs <- getCommentsFor l
1620 return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2]
1621 mkHsCasePV l c (L lm m) anns = do
1622 cs <- getCommentsFor l
1623 let mg = mkMatchGroup FromSource (L lm m)
1624 return $ L (noAnnSrcSpan l) (HsCmdCase (EpAnn (spanAsAnchor l) anns cs) c mg)
1625 mkHsLamCasePV l (L lm m) anns = do
1626 cs <- getCommentsFor l
1627 let mg = mkMatchGroup FromSource (L lm m)
1628 return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) mg)
1629 type FunArg (HsCmd GhcPs) = HsExpr GhcPs
1630 superFunArg m = m
1631 mkHsAppPV l c e = do
1632 cs <- getCommentsFor (locA l)
1633 checkCmdBlockArguments c
1634 checkExpBlockArguments e
1635 return $ L l (HsCmdApp (comment (realSrcSpan $ locA l) cs) c e)
1636 mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t)
1637 mkHsIfPV l c semi1 a semi2 b anns = do
1638 checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b
1639 cs <- getCommentsFor l
1640 return $ L (noAnnSrcSpan l) (mkHsCmdIf c a b (EpAnn (spanAsAnchor l) anns cs))
1641 mkHsDoPV l Nothing stmts anns = do
1642 cs <- getCommentsFor l
1643 return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts)
1644 mkHsDoPV l (Just m) _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
1645 mkHsParPV l lpar c rpar = do
1646 cs <- getCommentsFor l
1647 return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar)
1648 mkHsVarPV (L l v) = cmdFail (locA l) (ppr v)
1649 mkHsLitPV (L l a) = cmdFail l (ppr a)
1650 mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a)
1651 mkHsWildCardPV l = cmdFail l (text "_")
1652 mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig)
1653 mkHsExplicitListPV l xs _ = cmdFail l $
1654 brackets (fsep (punctuate comma (map ppr xs)))
1655 mkHsSplicePV (L l sp) = cmdFail l (ppr sp)
1656 mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do
1657 let (fs, ps) = partitionEithers fbinds
1658 if not (null ps)
1659 then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid
1660 else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc)
1661 mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a)
1662 mkHsSectionR_PV l op c = cmdFail l $
1663 let pp_op = fromMaybe (panic "cannot print infix operator")
1664 (ppr_infix_expr (unLoc op))
1665 in pp_op <> ppr c
1666 mkHsViewPatPV l a b _ = cmdFail l $
1667 ppr a <+> text "->" <+> ppr b
1668 mkHsAsPatPV l v c _ = cmdFail l $
1669 pprPrefixOcc (unLoc v) <> text "@" <> ppr c
1670 mkHsLazyPatPV l c _ = cmdFail l $
1671 text "~" <> ppr c
1672 mkHsBangPatPV l c _ = cmdFail l $
1673 text "!" <> ppr c
1674 mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a)
1675 rejectPragmaPV _ = return ()
1676
1677 cmdFail :: SrcSpan -> SDoc -> PV a
1678 cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e
1679
1680 checkLamMatchGroup :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV ()
1681 checkLamMatchGroup l (MG { mg_alts = (L _ (matches:_))}) = do
1682 when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda
1683 checkLamMatchGroup _ _ = return ()
1684
1685 instance DisambECP (HsExpr GhcPs) where
1686 type Body (HsExpr GhcPs) = HsExpr
1687 ecpFromCmd' (L l c) = do
1688 addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c
1689 return (L l (hsHoleExpr noAnn))
1690 ecpFromExp' = return
1691 mkHsProjUpdatePV l fields arg isPun anns = do
1692 cs <- getCommentsFor l
1693 return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs)
1694 mkHsLamPV l mg = do
1695 cs <- getCommentsFor l
1696 let mg' = mg cs
1697 checkLamMatchGroup l mg'
1698 return $ L (noAnnSrcSpan l) (HsLam NoExtField mg')
1699 mkHsLetPV l tkLet bs tkIn c = do
1700 cs <- getCommentsFor l
1701 return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn c)
1702 type InfixOp (HsExpr GhcPs) = HsExpr GhcPs
1703 superInfixOp m = m
1704 mkHsOpAppPV l e1 op e2 = do
1705 cs <- getCommentsFor l
1706 return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLocL op) e2
1707 mkHsCasePV l e (L lm m) anns = do
1708 cs <- getCommentsFor l
1709 let mg = mkMatchGroup FromSource (L lm m)
1710 return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg)
1711 mkHsLamCasePV l (L lm m) anns = do
1712 cs <- getCommentsFor l
1713 let mg = mkMatchGroup FromSource (L lm m)
1714 return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) mg)
1715 type FunArg (HsExpr GhcPs) = HsExpr GhcPs
1716 superFunArg m = m
1717 mkHsAppPV l e1 e2 = do
1718 cs <- getCommentsFor (locA l)
1719 checkExpBlockArguments e1
1720 checkExpBlockArguments e2
1721 return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2)
1722 mkHsAppTypePV l e la t = do
1723 checkExpBlockArguments e
1724 return $ L l (HsAppType la e (mkHsWildCardBndrs t))
1725 mkHsIfPV l c semi1 a semi2 b anns = do
1726 checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b
1727 cs <- getCommentsFor l
1728 return $ L (noAnnSrcSpan l) (mkHsIf c a b (EpAnn (spanAsAnchor l) anns cs))
1729 mkHsDoPV l mod stmts anns = do
1730 cs <- getCommentsFor l
1731 return $ L (noAnnSrcSpan l) (HsDo (EpAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts)
1732 mkHsParPV l lpar e rpar = do
1733 cs <- getCommentsFor l
1734 return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar)
1735 mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v)
1736 mkHsLitPV (L l a) = do
1737 cs <- getCommentsFor l
1738 return $ L l (HsLit (comment (realSrcSpan l) cs) a)
1739 mkHsOverLitPV (L l a) = do
1740 cs <- getCommentsFor (locA l)
1741 return $ L l (HsOverLit (comment (realSrcSpan (locA l)) cs) a)
1742 mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn)
1743 mkHsTySigPV l a sig anns = do
1744 cs <- getCommentsFor (locA l)
1745 return $ L l (ExprWithTySig (EpAnn (spanAsAnchor $ locA l) anns cs) a (hsTypeToHsSigWcType sig))
1746 mkHsExplicitListPV l xs anns = do
1747 cs <- getCommentsFor l
1748 return $ L (noAnnSrcSpan l) (ExplicitList (EpAnn (spanAsAnchor l) anns cs) xs)
1749 mkHsSplicePV sp@(L l _) = do
1750 cs <- getCommentsFor l
1751 return $ mapLoc (HsSpliceE (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp
1752 mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do
1753 cs <- getCommentsFor l
1754 r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (EpAnn (spanAsAnchor l) anns cs)
1755 checkRecordSyntax (L (noAnnSrcSpan l) r)
1756 mkHsNegAppPV l a anns = do
1757 cs <- getCommentsFor l
1758 return $ L (noAnnSrcSpan l) (NegApp (EpAnn (spanAsAnchor l) anns cs) a noSyntaxExpr)
1759 mkHsSectionR_PV l op e = do
1760 cs <- getCommentsFor l
1761 return $ L l (SectionR (comment (realSrcSpan l) cs) op e)
1762 mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b)
1763 >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
1764 mkHsAsPatPV l v e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)
1765 >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
1766 mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)
1767 >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
1768 mkHsBangPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e)
1769 >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
1770 mkSumOrTuplePV = mkSumOrTupleExpr
1771 rejectPragmaPV (L _ (OpApp _ _ _ e)) =
1772 -- assuming left-associative parsing of operators
1773 rejectPragmaPV e
1774 rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $
1775 (PsErrUnallowedPragma prag)
1776 rejectPragmaPV _ = return ()
1777
1778 hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs
1779 hsHoleExpr anns = HsUnboundVar anns (mkVarOcc "_")
1780
1781 type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcAnn NoEpAnns
1782 type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL
1783 type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA
1784 type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA
1785
1786 instance DisambECP (PatBuilder GhcPs) where
1787 type Body (PatBuilder GhcPs) = PatBuilder
1788 ecpFromCmd' (L l c) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c
1789 ecpFromExp' (L l e) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e
1790 mkHsLamPV l _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat
1791 mkHsLetPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat
1792 mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
1793 type InfixOp (PatBuilder GhcPs) = RdrName
1794 superInfixOp m = m
1795 mkHsOpAppPV l p1 op p2 = do
1796 cs <- getCommentsFor l
1797 let anns = EpAnn (spanAsAnchor l) [] cs
1798 return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns
1799 mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat
1800 mkHsLamCasePV l _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaCaseInPat
1801 type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
1802 superFunArg m = m
1803 mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
1804 mkHsAppTypePV l p la t = do
1805 cs <- getCommentsFor (locA l)
1806 let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs
1807 return $ L l (PatBuilderAppType p (mkHsPatSigType anns t))
1808 mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
1809 mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
1810 mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
1811 mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)
1812 mkHsLitPV lit@(L l a) = do
1813 checkUnboxedStringLitPat lit
1814 return $ L l (PatBuilderPat (LitPat noExtField a))
1815 mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)
1816 mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))
1817 mkHsTySigPV l b sig anns = do
1818 p <- checkLPat b
1819 cs <- getCommentsFor (locA l)
1820 return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType noAnn sig)))
1821 mkHsExplicitListPV l xs anns = do
1822 ps <- traverse checkLPat xs
1823 cs <- getCommentsFor l
1824 return (L (noAnnSrcSpan l) (PatBuilderPat (ListPat (EpAnn (spanAsAnchor l) anns cs) ps)))
1825 mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))
1826 mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do
1827 let (fs, ps) = partitionEithers fbinds
1828 if not (null ps)
1829 then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
1830 else do
1831 cs <- getCommentsFor l
1832 r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs)
1833 checkRecordSyntax (L (noAnnSrcSpan l) r)
1834 mkHsNegAppPV l (L lp p) anns = do
1835 lit <- case p of
1836 PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit)
1837 _ -> patFail l $ PsErrInPat p PEIP_NegApp
1838 cs <- getCommentsFor l
1839 let an = EpAnn (spanAsAnchor l) anns cs
1840 return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an))
1841 mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p))
1842 mkHsViewPatPV l a b anns = do
1843 p <- checkLPat b
1844 cs <- getCommentsFor l
1845 return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p))
1846 mkHsAsPatPV l v e a = do
1847 p <- checkLPat e
1848 cs <- getCommentsFor l
1849 return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (EpAnn (spanAsAnchor l) a cs) v p))
1850 mkHsLazyPatPV l e a = do
1851 p <- checkLPat e
1852 cs <- getCommentsFor l
1853 return $ L (noAnnSrcSpan l) (PatBuilderPat (LazyPat (EpAnn (spanAsAnchor l) a cs) p))
1854 mkHsBangPatPV l e an = do
1855 p <- checkLPat e
1856 cs <- getCommentsFor l
1857 let pb = BangPat (EpAnn (spanAsAnchor l) an cs) p
1858 hintBangPat l pb
1859 return $ L (noAnnSrcSpan l) (PatBuilderPat pb)
1860 mkSumOrTuplePV = mkSumOrTuplePat
1861 rejectPragmaPV _ = return ()
1862
1863 checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
1864 checkUnboxedStringLitPat (L loc lit) =
1865 case lit of
1866 HsStringPrim _ _ -- Trac #13260
1867 -> addFatalError $ mkPlainErrorMsgEnvelope loc $
1868 (PsErrIllegalUnboxedStringInPat lit)
1869 _ -> return ()
1870
1871 mkPatRec ::
1872 LocatedA (PatBuilder GhcPs) ->
1873 HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) ->
1874 EpAnn [AddEpAnn] ->
1875 PV (PatBuilder GhcPs)
1876 mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns
1877 | isRdrDataCon (unLoc c)
1878 = do fs <- mapM checkPatField fs
1879 return $ PatBuilderPat $ ConPat
1880 { pat_con_ext = anns
1881 , pat_con = c
1882 , pat_args = RecCon (HsRecFields fs dd)
1883 }
1884 mkPatRec p _ _ =
1885 addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $
1886 (PsErrInvalidRecordCon (unLoc p))
1887
1888 -- | Disambiguate constructs that may appear when we do not know
1889 -- ahead of time whether we are parsing a type or a newtype/data constructor.
1890 --
1891 -- See Note [Ambiguous syntactic categories] for the general idea.
1892 --
1893 -- See Note [Parsing data constructors is hard] for the specific issue this
1894 -- particular class is solving.
1895 --
1896 class DisambTD b where
1897 -- | Process the head of a type-level function/constructor application,
1898 -- i.e. the @H@ in @H a b c@.
1899 mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b)
1900 -- | Disambiguate @f x@ (function application or prefix data constructor).
1901 mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b)
1902 -- | Disambiguate @f \@t@ (visible kind application)
1903 mkHsAppKindTyPV :: LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b)
1904 -- | Disambiguate @f \# x@ (infix operator)
1905 mkHsOpTyPV :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)
1906 -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)
1907 mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)
1908
1909 instance DisambTD (HsType GhcPs) where
1910 mkHsAppTyHeadPV = return
1911 mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
1912 mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l_at t ki)
1913 mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2)
1914 mkUnpackednessPV = addUnpackednessP
1915
1916 dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
1917 dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
1918 dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
1919
1920 dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs
1921
1922 -- Detect when the record syntax is used:
1923 -- data T = MkT { ... }
1924 dataConBuilderDetails (PrefixDataConBuilder flds _)
1925 | [L l_t (HsRecTy an fields)] <- toList flds
1926 = RecCon (L (SrcSpanAnn an (locA l_t)) fields)
1927
1928 -- Normal prefix constructor, e.g. data T = MkT A B C
1929 dataConBuilderDetails (PrefixDataConBuilder flds _)
1930 = PrefixCon noTypeArgs (map hsLinear (toList flds))
1931
1932 -- Infix constructor, e.g. data T = Int :! Bool
1933 dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)
1934 = InfixCon (hsLinear lhs) (hsLinear rhs)
1935
1936 instance DisambTD DataConBuilder where
1937 mkHsAppTyHeadPV = tyToDataConBuilder
1938
1939 mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t =
1940 return $
1941 L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t))
1942 (PrefixDataConBuilder (flds `snocOL` t) fn)
1943 mkHsAppTyPV (L _ InfixDataConBuilder{}) _ =
1944 -- This case is impossible because of the way
1945 -- the grammar in Parser.y is written (see infixtype/ftype).
1946 panic "mkHsAppTyPV: InfixDataConBuilder"
1947
1948 mkHsAppKindTyPV lhs l_at ki =
1949 addFatalError $ mkPlainErrorMsgEnvelope l_at $
1950 (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))
1951
1952 mkHsOpTyPV lhs tc rhs = do
1953 check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative
1954 data_con <- eitherToP $ tyConToDataCon tc
1955 return $ L l (InfixDataConBuilder lhs data_con rhs)
1956 where
1957 l = combineLocsA lhs rhs
1958 check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
1959 check_no_ops (HsOpTy{}) =
1960 addError $ mkPlainErrorMsgEnvelope (locA l) $
1961 (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs))
1962 check_no_ops _ = return ()
1963
1964 mkUnpackednessPV unpk constr_stuff
1965 | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff
1966 = -- When the user writes data T = {-# UNPACK #-} Int :+ Bool
1967 -- we apply {-# UNPACK #-} to the LHS
1968 do lhs' <- addUnpackednessP unpk lhs
1969 let l = combineLocsA (reLocA unpk) constr_stuff
1970 return $ L l (InfixDataConBuilder lhs' data_con rhs)
1971 | otherwise =
1972 do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon
1973 return constr_stuff
1974
1975 tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)
1976 tyToDataConBuilder (L l (HsTyVar _ NotPromoted v)) = do
1977 data_con <- eitherToP $ tyConToDataCon v
1978 return $ L l (PrefixDataConBuilder nilOL data_con)
1979 tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do
1980 let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))
1981 return $ L l (PrefixDataConBuilder (toOL ts) data_con)
1982 tyToDataConBuilder t =
1983 addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $
1984 (PsErrInvalidDataCon (unLoc t))
1985
1986 {- Note [Ambiguous syntactic categories]
1987 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1988 There are places in the grammar where we do not know whether we are parsing an
1989 expression or a pattern without unlimited lookahead (which we do not have in
1990 'happy'):
1991
1992 View patterns:
1993
1994 f (Con a b ) = ... -- 'Con a b' is a pattern
1995 f (Con a b -> x) = ... -- 'Con a b' is an expression
1996
1997 do-notation:
1998
1999 do { Con a b <- x } -- 'Con a b' is a pattern
2000 do { Con a b } -- 'Con a b' is an expression
2001
2002 Guards:
2003
2004 x | True <- p && q = ... -- 'True' is a pattern
2005 x | True = ... -- 'True' is an expression
2006
2007 Top-level value/function declarations (FunBind/PatBind):
2008
2009 f ! a -- TH splice
2010 f ! a = ... -- function declaration
2011
2012 Until we encounter the = sign, we don't know if it's a top-level
2013 TemplateHaskell splice where ! is used, or if it's a function declaration
2014 where ! is bound.
2015
2016 There are also places in the grammar where we do not know whether we are
2017 parsing an expression or a command:
2018
2019 proc x -> do { (stuff) -< x } -- 'stuff' is an expression
2020 proc x -> do { (stuff) } -- 'stuff' is a command
2021
2022 Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff'
2023 as an expression or a command.
2024
2025 In fact, do-notation is subject to both ambiguities:
2026
2027 proc x -> do { (stuff) -< x } -- 'stuff' is an expression
2028 proc x -> do { (stuff) <- f -< x } -- 'stuff' is a pattern
2029 proc x -> do { (stuff) } -- 'stuff' is a command
2030
2031 There are many possible solutions to this problem. For an overview of the ones
2032 we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives]
2033
2034 The solution that keeps basic definitions (such as HsExpr) clean, keeps the
2035 concerns local to the parser, and does not require duplication of hsSyn types,
2036 or an extra pass over the entire AST, is to parse into an overloaded
2037 parser-validator (a so-called tagless final encoding):
2038
2039 class DisambECP b where ...
2040 instance DisambECP (HsCmd GhcPs) where ...
2041 instance DisambECP (HsExp GhcPs) where ...
2042 instance DisambECP (PatBuilder GhcPs) where ...
2043
2044 The 'DisambECP' class contains functions to build and validate 'b'. For example,
2045 to add parentheses we have:
2046
2047 mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)
2048
2049 'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for
2050 expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat,
2051 see Note [PatBuilder]).
2052
2053 Consider the 'alts' production used to parse case-of alternatives:
2054
2055 alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
2056 : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
2057 | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
2058
2059 We abstract over LHsExpr GhcPs, and it becomes:
2060
2061 alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located b)])) }
2062 : alts1 { $1 >>= \ $1 ->
2063 return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
2064 | ';' alts { $2 >>= \ $2 ->
2065 return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
2066
2067 Compared to the initial definition, the added bits are:
2068
2069 forall b. DisambECP b => PV ( ... ) -- in the type signature
2070 $1 >>= \ $1 -> return $ -- in one reduction rule
2071 $2 >>= \ $2 -> return $ -- in another reduction rule
2072
2073 The overhead is constant relative to the size of the rest of the reduction
2074 rule, so this approach scales well to large parser productions.
2075
2076 Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding
2077 position and shadows the previous $1. We can do this because internally
2078 'happy' desugars $n to happy_var_n, and the rationale behind this idiom
2079 is to be able to write (sLL $1 $>) later on. The alternative would be to
2080 write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer
2081 to the last fresh name as $>.
2082
2083 Finally, we instantiate the polymorphic type to a concrete one, and run the
2084 parser-validator, for example:
2085
2086 stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
2087 e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
2088 : stmt {% runPV $1 }
2089
2090 In e_stmt, three things happen:
2091
2092 1. we instantiate: b ~ HsExpr GhcPs
2093 2. we embed the PV computation into P by using runPV
2094 3. we run validation by using a monadic production, {% ... }
2095
2096 At this point the ambiguity is resolved.
2097 -}
2098
2099
2100 {- Note [Resolving parsing ambiguities: non-taken alternatives]
2101 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2102
2103 Alternative I, extra constructors in GHC.Hs.Expr
2104 ------------------------------------------------
2105 We could add extra constructors to HsExpr to represent command-specific and
2106 pattern-specific syntactic constructs. Under this scheme, we parse patterns
2107 and commands as expressions and rejig later. This is what GHC used to do, and
2108 it polluted 'HsExpr' with irrelevant constructors:
2109
2110 * for commands: 'HsArrForm', 'HsArrApp'
2111 * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat'
2112
2113 (As of now, we still do that for patterns, but we plan to fix it).
2114
2115 There are several issues with this:
2116
2117 * The implementation details of parsing are leaking into hsSyn definitions.
2118
2119 * Code that uses HsExpr has to panic on these impossible-after-parsing cases.
2120
2121 * HsExpr is arbitrarily selected as the extension basis. Why not extend
2122 HsCmd or HsPat with extra constructors instead?
2123
2124 Alternative II, extra constructors in GHC.Hs.Expr for GhcPs
2125 -----------------------------------------------------------
2126 We could address some of the problems with Alternative I by using Trees That
2127 Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to
2128 the output of parsing, not to its intermediate results, so we wouldn't want
2129 them there either.
2130
2131 Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs
2132 ---------------------------------------------------------------
2133 We could introduce a new pass, GhcPrePs, to keep GhcPs pristine.
2134 Unfortunately, creating a new pass would significantly bloat conversion code
2135 and slow down the compiler by adding another linear-time pass over the entire
2136 AST. For example, in order to build HsExpr GhcPrePs, we would need to build
2137 HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds
2138 GhcPrePs.
2139
2140
2141 Alternative IV, sum type and bottom-up data flow
2142 ------------------------------------------------
2143 Expressions and commands are disjoint. There are no user inputs that could be
2144 interpreted as either an expression or a command depending on outer context:
2145
2146 5 -- definitely an expression
2147 x -< y -- definitely a command
2148
2149 Even though we have both 'HsLam' and 'HsCmdLam', we can look at
2150 the body to disambiguate:
2151
2152 \p -> 5 -- definitely an expression
2153 \p -> x -< y -- definitely a command
2154
2155 This means we could use a bottom-up flow of information to determine
2156 whether we are parsing an expression or a command, using a sum type
2157 for intermediate results:
2158
2159 Either (LHsExpr GhcPs) (LHsCmd GhcPs)
2160
2161 There are two problems with this:
2162
2163 * We cannot handle the ambiguity between expressions and
2164 patterns, which are not disjoint.
2165
2166 * Bottom-up flow of information leads to poor error messages. Consider
2167
2168 if ... then 5 else (x -< y)
2169
2170 Do we report that '5' is not a valid command or that (x -< y) is not a
2171 valid expression? It depends on whether we want the entire node to be
2172 'HsIf' or 'HsCmdIf', and this information flows top-down, from the
2173 surrounding parsing context (are we in 'proc'?)
2174
2175 Alternative V, backtracking with parser combinators
2176 ---------------------------------------------------
2177 One might think we could sidestep the issue entirely by using a backtracking
2178 parser and doing something along the lines of (try pExpr <|> pPat).
2179
2180 Turns out, this wouldn't work very well, as there can be patterns inside
2181 expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns
2182 (e.g. view patterns). To handle this, we would need to backtrack while
2183 backtracking, and unbound levels of backtracking lead to very fragile
2184 performance.
2185
2186 Alternative VI, an intermediate data type
2187 -----------------------------------------
2188 There are common syntactic elements of expressions, commands, and patterns
2189 (e.g. all of them must have balanced parentheses), and we can capture this
2190 common structure in an intermediate data type, Frame:
2191
2192 data Frame
2193 = FrameVar RdrName
2194 -- ^ Identifier: Just, map, BS.length
2195 | FrameTuple [LTupArgFrame] Boxity
2196 -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,)
2197 | FrameTySig LFrame (LHsSigWcType GhcPs)
2198 -- ^ Type signature: x :: ty
2199 | FramePar (SrcSpan, SrcSpan) LFrame
2200 -- ^ Parentheses
2201 | FrameIf LFrame LFrame LFrame
2202 -- ^ If-expression: if p then x else y
2203 | FrameCase LFrame [LFrameMatch]
2204 -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }
2205 | FrameDo (HsStmtContext GhcRn) [LFrameStmt]
2206 -- ^ Do-expression: do { s1; a <- s2; s3 }
2207 ...
2208 | FrameExpr (HsExpr GhcPs) -- unambiguously an expression
2209 | FramePat (HsPat GhcPs) -- unambiguously a pattern
2210 | FrameCommand (HsCmd GhcPs) -- unambiguously a command
2211
2212 To determine which constructors 'Frame' needs to have, we take the union of
2213 intersections between HsExpr, HsCmd, and HsPat.
2214
2215 The intersection between HsPat and HsExpr:
2216
2217 HsPat = VarPat | TuplePat | SigPat | ParPat | ...
2218 HsExpr = HsVar | ExplicitTuple | ExprWithTySig | HsPar | ...
2219 -------------------------------------------------------------------
2220 Frame = FrameVar | FrameTuple | FrameTySig | FramePar | ...
2221
2222 The intersection between HsCmd and HsExpr:
2223
2224 HsCmd = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar
2225 HsExpr = HsIf | HsCase | HsDo | HsPar
2226 ------------------------------------------------
2227 Frame = FrameIf | FrameCase | FrameDo | FramePar
2228
2229 The intersection between HsCmd and HsPat:
2230
2231 HsPat = ParPat | ...
2232 HsCmd = HsCmdPar | ...
2233 -----------------------
2234 Frame = FramePar | ...
2235
2236 Take the union of each intersection and this yields the final 'Frame' data
2237 type. The problem with this approach is that we end up duplicating a good
2238 portion of hsSyn:
2239
2240 Frame for HsExpr, HsPat, HsCmd
2241 TupArgFrame for HsTupArg
2242 FrameMatch for Match
2243 FrameStmt for StmtLR
2244 FrameGRHS for GRHS
2245 FrameGRHSs for GRHSs
2246 ...
2247
2248 Alternative VII, a product type
2249 -------------------------------
2250 We could avoid the intermediate representation of Alternative VI by parsing
2251 into a product of interpretations directly:
2252
2253 type ExpCmdPat = ( PV (LHsExpr GhcPs)
2254 , PV (LHsCmd GhcPs)
2255 , PV (LHsPat GhcPs) )
2256
2257 This means that in positions where we do not know whether to produce
2258 expression, a pattern, or a command, we instead produce a parser-validator for
2259 each possible option.
2260
2261 Then, as soon as we have parsed far enough to resolve the ambiguity, we pick
2262 the appropriate component of the product, discarding the rest:
2263
2264 checkExpOf3 (e, _, _) = e -- interpret as an expression
2265 checkCmdOf3 (_, c, _) = c -- interpret as a command
2266 checkPatOf3 (_, _, p) = p -- interpret as a pattern
2267
2268 We can easily define ambiguities between arbitrary subsets of interpretations.
2269 For example, when we know ahead of type that only an expression or a command is
2270 possible, but not a pattern, we can use a smaller type:
2271
2272 type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))
2273
2274 checkExpOf2 (e, _) = e -- interpret as an expression
2275 checkCmdOf2 (_, c) = c -- interpret as a command
2276
2277 However, there is a slight problem with this approach, namely code duplication
2278 in parser productions. Consider the 'alts' production used to parse case-of
2279 alternatives:
2280
2281 alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
2282 : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
2283 | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
2284
2285 Under the new scheme, we have to completely duplicate its type signature and
2286 each reduction rule:
2287
2288 alts :: { ( PV (Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression
2289 , PV (Located ([AddEpAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command
2290 ) }
2291 : alts1
2292 { ( checkExpOf2 $1 >>= \ $1 ->
2293 return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)
2294 , checkCmdOf2 $1 >>= \ $1 ->
2295 return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)
2296 ) }
2297 | ';' alts
2298 { ( checkExpOf2 $2 >>= \ $2 ->
2299 return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)
2300 , checkCmdOf2 $2 >>= \ $2 ->
2301 return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)
2302 ) }
2303
2304 And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',
2305 'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!
2306
2307 Alternative VIII, a function from a GADT
2308 ----------------------------------------
2309 We could avoid code duplication of the Alternative VII by representing the product
2310 as a function from a GADT:
2311
2312 data ExpCmdG b where
2313 ExpG :: ExpCmdG HsExpr
2314 CmdG :: ExpCmdG HsCmd
2315
2316 type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))
2317
2318 checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
2319 checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
2320 checkExp f = f ExpG -- interpret as an expression
2321 checkCmd f = f CmdG -- interpret as a command
2322
2323 Consider the 'alts' production used to parse case-of alternatives:
2324
2325 alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
2326 : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
2327 | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
2328
2329 We abstract over LHsExpr, and it becomes:
2330
2331 alts :: { forall b. ExpCmdG b -> PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }
2332 : alts1
2333 { \tag -> $1 tag >>= \ $1 ->
2334 return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
2335 | ';' alts
2336 { \tag -> $2 tag >>= \ $2 ->
2337 return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
2338
2339 Note that 'ExpCmdG' is a singleton type, the value is completely
2340 determined by the type:
2341
2342 when (b~HsExpr), tag = ExpG
2343 when (b~HsCmd), tag = CmdG
2344
2345 This is a clear indication that we can use a class to pass this value behind
2346 the scenes:
2347
2348 class ExpCmdI b where expCmdG :: ExpCmdG b
2349 instance ExpCmdI HsExpr where expCmdG = ExpG
2350 instance ExpCmdI HsCmd where expCmdG = CmdG
2351
2352 And now the 'alts' production is simplified, as we no longer need to
2353 thread 'tag' explicitly:
2354
2355 alts :: { forall b. ExpCmdI b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }
2356 : alts1 { $1 >>= \ $1 ->
2357 return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
2358 | ';' alts { $2 >>= \ $2 ->
2359 return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
2360
2361 This encoding works well enough, but introduces an extra GADT unlike the
2362 tagless final encoding, and there's no need for this complexity.
2363
2364 -}
2365
2366 {- Note [PatBuilder]
2367 ~~~~~~~~~~~~~~~~~~~~
2368 Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,
2369 so we introduce the notion of a PatBuilder.
2370
2371 Consider a pattern like this:
2372
2373 Con a b c
2374
2375 We parse arguments to "Con" one at a time in the fexp aexp parser production,
2376 building the result with mkHsAppPV, so the intermediate forms are:
2377
2378 1. Con
2379 2. Con a
2380 3. Con a b
2381 4. Con a b c
2382
2383 In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like
2384 this (pseudocode):
2385
2386 1. "Con"
2387 2. HsApp "Con" "a"
2388 3. HsApp (HsApp "Con" "a") "b"
2389 3. HsApp (HsApp (HsApp "Con" "a") "b") "c"
2390
2391 Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have
2392 instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for
2393 the intermediate forms.
2394
2395 We also need an intermediate representation to postpone disambiguation between
2396 FunBind and PatBind. Consider:
2397
2398 a `Con` b = ...
2399 a `fun` b = ...
2400
2401 How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We
2402 learn this by inspecting an intermediate representation in 'isFunLhs' and
2403 seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate
2404 representation capable of representing both a FunBind and a PatBind, so Pat is
2405 insufficient.
2406
2407 PatBuilder is an extension of Pat that is capable of representing intermediate
2408 parsing results for patterns and function bindings:
2409
2410 data PatBuilder p
2411 = PatBuilderPat (Pat p)
2412 | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))
2413 | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p))
2414 ...
2415
2416 It can represent any pattern via 'PatBuilderPat', but it also has a variety of
2417 other constructors which were added by following a simple principle: we never
2418 pattern match on the pattern stored inside 'PatBuilderPat'.
2419 -}
2420
2421 ---------------------------------------------------------------------------
2422 -- Miscellaneous utilities
2423
2424 -- | Check if a fixity is valid. We support bypassing the usual bound checks
2425 -- for some special operators.
2426 checkPrecP
2427 :: Located (SourceText,Int) -- ^ precedence
2428 -> Located (OrdList (LocatedN RdrName)) -- ^ operators
2429 -> P ()
2430 checkPrecP (L l (_,i)) (L _ ol)
2431 | 0 <= i, i <= maxPrecedence = pure ()
2432 | all specialOp ol = pure ()
2433 | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i)
2434 where
2435 -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs
2436 specialOp op = unLoc op `elem` [ eqTyCon_RDR
2437 , getRdrName unrestrictedFunTyCon ]
2438
2439 mkRecConstrOrUpdate
2440 :: Bool
2441 -> LHsExpr GhcPs
2442 -> SrcSpan
2443 -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)
2444 -> EpAnn [AddEpAnn]
2445 -> PV (HsExpr GhcPs)
2446 mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns
2447 | isRdrDataCon c
2448 = do
2449 let (fs, ps) = partitionEithers fbinds
2450 if not (null ps)
2451 then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $
2452 PsErrOverloadedRecordDotInvalid
2453 else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)
2454 mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns
2455 | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $
2456 PsErrDotsInRecordUpdate
2457 | otherwise = mkRdrRecordUpd overloaded_update exp fs anns
2458
2459 mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)
2460 mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
2461 -- We do not need to know if OverloadedRecordDot is in effect. We do
2462 -- however need to know if OverloadedRecordUpdate (passed in
2463 -- overloaded_on) is in effect because it affects the Left/Right nature
2464 -- of the RecordUpd value we calculate.
2465 let (fs, ps) = partitionEithers fbinds
2466 fs' :: [LHsRecUpdField GhcPs]
2467 fs' = map (fmap mk_rec_upd_field) fs
2468 case overloaded_on of
2469 False | not $ null ps ->
2470 -- A '.' was found in an update and OverloadedRecordUpdate isn't on.
2471 addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled
2472 False ->
2473 -- This is just a regular record update.
2474 return RecordUpd {
2475 rupd_ext = anns
2476 , rupd_expr = exp
2477 , rupd_flds = Left fs' }
2478 True -> do
2479 let qualifiedFields =
2480 [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'
2481 , isQual . rdrNameAmbiguousFieldOcc $ lbl
2482 ]
2483 if not $ null qualifiedFields
2484 then
2485 addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head qualifiedFields)) $
2486 PsErrOverloadedRecordUpdateNoQualifiedFields
2487 else -- This is a RecordDotSyntax update.
2488 return RecordUpd {
2489 rupd_ext = anns
2490 , rupd_expr = exp
2491 , rupd_flds = Right (toProjUpdates fbinds) }
2492 where
2493 toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]
2494 toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f })
2495
2496 -- Convert a top-level field update like {foo=2} or {bar} (punned)
2497 -- to a projection update.
2498 recFieldToProjUpdate :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs
2499 recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =
2500 -- The idea here is to convert the label to a singleton [FastString].
2501 let f = occNameFS . rdrNameOcc $ rdr
2502 fl = DotFieldOcc noAnn (L (l2l loc) f) -- AZ: what about the ann?
2503 lf = locA loc
2504 in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns
2505 where
2506 -- If punning, compute HsVar "f" otherwise just arg. This
2507 -- has the effect that sentinel HsVar "pun-rhs" is replaced
2508 -- by HsVar "f" here, before the update is written to a
2509 -- setField expressions.
2510 punnedVar :: FastString -> LHsExpr GhcPs
2511 punnedVar f = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f
2512
2513 mkRdrRecordCon
2514 :: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs
2515 mkRdrRecordCon con flds anns
2516 = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds }
2517
2518 mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg
2519 mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
2520 mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs
2521 , rec_dotdot = Just (L s (length fs)) }
2522
2523 mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
2524 mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)
2525 = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun
2526
2527 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
2528 -> InlinePragma
2529 -- The (Maybe Activation) is because the user can omit
2530 -- the activation spec (and usually does)
2531 mkInlinePragma src (inl, match_info) mb_act
2532 = InlinePragma { inl_src = src -- Note [Pragma source text] in GHC.Types.SourceText
2533 , inl_inline = inl
2534 , inl_sat = Nothing
2535 , inl_act = act
2536 , inl_rule = match_info }
2537 where
2538 act = case mb_act of
2539 Just act -> act
2540 Nothing -> -- No phase specified
2541 case inl of
2542 NoInline _ -> NeverActive
2543 _other -> AlwaysActive
2544
2545 -----------------------------------------------------------------------------
2546 -- utilities for foreign declarations
2547
2548 -- construct a foreign import declaration
2549 --
2550 mkImport :: Located CCallConv
2551 -> Located Safety
2552 -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
2553 -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)
2554 mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
2555 case unLoc cconv of
2556 CCallConv -> returnSpec =<< mkCImport
2557 CApiConv -> do
2558 imp <- mkCImport
2559 if isCWrapperImport imp
2560 then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport
2561 else returnSpec imp
2562 StdCallConv -> returnSpec =<< mkCImport
2563 PrimCallConv -> mkOtherImport
2564 JavaScriptCallConv -> mkOtherImport
2565 where
2566 -- Parse a C-like entity string of the following form:
2567 -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"
2568 -- If 'cid' is missing, the function name 'v' is used instead as symbol
2569 -- name (cf section 8.5.1 in Haskell 2010 report).
2570 mkCImport = do
2571 let e = unpackFS entity
2572 case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
2573 Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $
2574 PsErrMalformedEntityString
2575 Just importSpec -> return importSpec
2576
2577 isCWrapperImport (CImport _ _ _ CWrapper _) = True
2578 isCWrapperImport _ = False
2579
2580 -- currently, all the other import conventions only support a symbol name in
2581 -- the entity string. If it is missing, we use the function name instead.
2582 mkOtherImport = returnSpec importSpec
2583 where
2584 entity' = if nullFS entity
2585 then mkExtName (unLoc v)
2586 else entity
2587 funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
2588 importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
2589
2590 returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport
2591 { fd_i_ext = ann
2592 , fd_name = v
2593 , fd_sig_ty = ty
2594 , fd_fi = spec
2595 }
2596
2597
2598
2599 -- the string "foo" is ambiguous: either a header or a C identifier. The
2600 -- C identifier case comes first in the alternatives below, so we pick
2601 -- that one.
2602 parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
2603 -> Located SourceText
2604 -> Maybe ForeignImport
2605 parseCImport cconv safety nm str sourceText =
2606 listToMaybe $ map fst $ filter (null.snd) $
2607 readP_to_S parse str
2608 where
2609 parse = do
2610 skipSpaces
2611 r <- choice [
2612 string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
2613 string "wrapper" >> return (mk Nothing CWrapper),
2614 do optional (token "static" >> skipSpaces)
2615 ((mk Nothing <$> cimp nm) +++
2616 (do h <- munch1 hdr_char
2617 skipSpaces
2618 mk (Just (Header (SourceText h) (mkFastString h)))
2619 <$> cimp nm))
2620 ]
2621 skipSpaces
2622 return r
2623
2624 token str = do _ <- string str
2625 toks <- look
2626 case toks of
2627 c : _
2628 | id_char c -> pfail
2629 _ -> return ()
2630
2631 mk h n = CImport cconv safety h n sourceText
2632
2633 hdr_char c = not (isSpace c)
2634 -- header files are filenames, which can contain
2635 -- pretty much any char (depending on the platform),
2636 -- so just accept any non-space character
2637 id_first_char c = isAlpha c || c == '_'
2638 id_char c = isAlphaNum c || c == '_'
2639
2640 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
2641 +++ (do isFun <- case unLoc cconv of
2642 CApiConv ->
2643 option True
2644 (do token "value"
2645 skipSpaces
2646 return False)
2647 _ -> return True
2648 cid' <- cid
2649 return (CFunction (StaticTarget NoSourceText cid'
2650 Nothing isFun)))
2651 where
2652 cid = return nm +++
2653 (do c <- satisfy id_first_char
2654 cs <- many (satisfy id_char)
2655 return (mkFastString (c:cs)))
2656
2657
2658 -- construct a foreign export declaration
2659 --
2660 mkExport :: Located CCallConv
2661 -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
2662 -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)
2663 mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)
2664 = return $ \ann -> ForD noExtField $
2665 ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty
2666 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
2667 (L le esrc) }
2668 where
2669 entity' | nullFS entity = mkExtName (unLoc v)
2670 | otherwise = entity
2671
2672 -- Supplying the ext_name in a foreign decl is optional; if it
2673 -- isn't there, the Haskell name is assumed. Note that no transformation
2674 -- of the Haskell name is then performed, so if you foreign export (++),
2675 -- it's external name will be "++". Too bad; it's important because we don't
2676 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
2677 --
2678 mkExtName :: RdrName -> CLabelString
2679 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
2680
2681 --------------------------------------------------------------------------------
2682 -- Help with module system imports/exports
2683
2684 data ImpExpSubSpec = ImpExpAbs
2685 | ImpExpAll
2686 | ImpExpList [LocatedA ImpExpQcSpec]
2687 | ImpExpAllWith [LocatedA ImpExpQcSpec]
2688
2689 data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)
2690 | ImpExpQcType EpaLocation (LocatedN RdrName)
2691 | ImpExpQcWildcard
2692
2693 mkModuleImpExp :: [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
2694 mkModuleImpExp anns (L l specname) subs = do
2695 cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments
2696 let ann = EpAnn (spanAsAnchor $ locA l) anns cs
2697 case subs of
2698 ImpExpAbs
2699 | isVarNameSpace (rdrNameSpace name)
2700 -> return $ IEVar noExtField (L l (ieNameFromSpec specname))
2701 | otherwise -> IEThingAbs ann . L l <$> nameT
2702 ImpExpAll -> IEThingAll ann . L l <$> nameT
2703 ImpExpList xs ->
2704 (\newName -> IEThingWith ann (L l newName)
2705 NoIEWildcard (wrapped xs)) <$> nameT
2706 ImpExpAllWith xs ->
2707 do allowed <- getBit PatternSynonymsBit
2708 if allowed
2709 then
2710 let withs = map unLoc xs
2711 pos = maybe NoIEWildcard IEWildcard
2712 (findIndex isImpExpQcWildcard withs)
2713 ies :: [LocatedA (IEWrappedName RdrName)]
2714 ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
2715 in (\newName
2716 -> IEThingWith ann (L l newName) pos ies)
2717 <$> nameT
2718 else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
2719 PsErrIllegalPatSynExport
2720 where
2721 name = ieNameVal specname
2722 nameT =
2723 if isVarNameSpace (rdrNameSpace name)
2724 then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
2725 (PsErrVarForTyCon name)
2726 else return $ ieNameFromSpec specname
2727
2728 ieNameVal (ImpExpQcName ln) = unLoc ln
2729 ieNameVal (ImpExpQcType _ ln) = unLoc ln
2730 ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard"
2731
2732 ieNameFromSpec (ImpExpQcName ln) = IEName ln
2733 ieNameFromSpec (ImpExpQcType r ln) = IEType r ln
2734 ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
2735
2736 wrapped = map (mapLoc ieNameFromSpec)
2737
2738 mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space
2739 -> P (LocatedN RdrName)
2740 mkTypeImpExp name =
2741 do allowed <- getBit ExplicitNamespacesBit
2742 unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $
2743 PsErrIllegalExplicitNamespace
2744 return (fmap (`setRdrNameSpace` tcClsName) name)
2745
2746 checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])
2747 checkImportSpec ie@(L _ specs) =
2748 case [l | (L l (IEThingWith _ _ (IEWildcard _) _)) <- specs] of
2749 [] -> return ie
2750 (l:_) -> importSpecError (locA l)
2751 where
2752 importSpecError l =
2753 addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm
2754
2755 -- In the correct order
2756 mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)
2757 mkImpExpSubSpec [] = return ([], ImpExpList [])
2758 mkImpExpSubSpec [L la ImpExpQcWildcard] =
2759 return ([AddEpAnn AnnDotdot (EpaSpan $ la2r la)], ImpExpAll)
2760 mkImpExpSubSpec xs =
2761 if (any (isImpExpQcWildcard . unLoc) xs)
2762 then return $ ([], ImpExpAllWith xs)
2763 else return $ ([], ImpExpList xs)
2764
2765 isImpExpQcWildcard :: ImpExpQcSpec -> Bool
2766 isImpExpQcWildcard ImpExpQcWildcard = True
2767 isImpExpQcWildcard _ = False
2768
2769 -----------------------------------------------------------------------------
2770 -- Warnings and failures
2771
2772 warnPrepositiveQualifiedModule :: SrcSpan -> P ()
2773 warnPrepositiveQualifiedModule span =
2774 addPsMessage span PsWarnImportPreQualified
2775
2776 failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()
2777 failOpNotEnabledImportQualifiedPost loc =
2778 addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified
2779
2780 failOpImportQualifiedTwice :: SrcSpan -> P ()
2781 failOpImportQualifiedTwice loc =
2782 addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice
2783
2784 warnStarIsType :: SrcSpan -> P ()
2785 warnStarIsType span = addPsMessage span PsWarnStarIsType
2786
2787 failOpFewArgs :: MonadP m => LocatedN RdrName -> m a
2788 failOpFewArgs (L loc op) =
2789 do { star_is_type <- getBit StarIsTypeBit
2790 ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
2791 (PsErrOpFewArgs (StarIsType star_is_type) op) }
2792
2793 -----------------------------------------------------------------------------
2794 -- Misc utils
2795
2796 data PV_Context =
2797 PV_Context
2798 { pv_options :: ParserOpts
2799 , pv_details :: ParseContext -- See Note [Parser-Validator Details]
2800 }
2801
2802 data PV_Accum =
2803 PV_Accum
2804 { pv_warnings :: Messages PsMessage
2805 , pv_errors :: Messages PsMessage
2806 , pv_header_comments :: Strict.Maybe [LEpaComment]
2807 , pv_comment_q :: [LEpaComment]
2808 }
2809
2810 data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum
2811
2812 -- During parsing, we make use of several monadic effects: reporting parse errors,
2813 -- accumulating warnings, adding API annotations, and checking for extensions. These
2814 -- effects are captured by the 'MonadP' type class.
2815 --
2816 -- Sometimes we need to postpone some of these effects to a later stage due to
2817 -- ambiguities described in Note [Ambiguous syntactic categories].
2818 -- We could use two layers of the P monad, one for each stage:
2819 --
2820 -- abParser :: forall x. DisambAB x => P (P x)
2821 --
2822 -- The outer layer of P consumes the input and builds the inner layer, which
2823 -- validates the input. But this type is not particularly helpful, as it obscures
2824 -- the fact that the inner layer of P never consumes any input.
2825 --
2826 -- For clarity, we introduce the notion of a parser-validator: a parser that does
2827 -- not consume any input, but may fail or use other effects. Thus we have:
2828 --
2829 -- abParser :: forall x. DisambAB x => P (PV x)
2830 --
2831 newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }
2832
2833 instance Functor PV where
2834 fmap = liftM
2835
2836 instance Applicative PV where
2837 pure a = a `seq` PV (\_ acc -> PV_Ok acc a)
2838 (<*>) = ap
2839
2840 instance Monad PV where
2841 m >>= f = PV $ \ctx acc ->
2842 case unPV m ctx acc of
2843 PV_Ok acc' a -> unPV (f a) ctx acc'
2844 PV_Failed acc' -> PV_Failed acc'
2845
2846 runPV :: PV a -> P a
2847 runPV = runPV_details noParseContext
2848
2849 askParseContext :: PV ParseContext
2850 askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details
2851
2852 runPV_details :: ParseContext -> PV a -> P a
2853 runPV_details details m =
2854 P $ \s ->
2855 let
2856 pv_ctx = PV_Context
2857 { pv_options = options s
2858 , pv_details = details }
2859 pv_acc = PV_Accum
2860 { pv_warnings = warnings s
2861 , pv_errors = errors s
2862 , pv_header_comments = header_comments s
2863 , pv_comment_q = comment_q s }
2864 mkPState acc' =
2865 s { warnings = pv_warnings acc'
2866 , errors = pv_errors acc'
2867 , comment_q = pv_comment_q acc' }
2868 in
2869 case unPV m pv_ctx pv_acc of
2870 PV_Ok acc' a -> POk (mkPState acc') a
2871 PV_Failed acc' -> PFailed (mkPState acc')
2872
2873 instance MonadP PV where
2874 addError err =
2875 PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} ()
2876 addWarning w =
2877 PV $ \_ctx acc ->
2878 -- No need to check for the warning flag to be set, GHC will correctly discard suppressed
2879 -- diagnostics.
2880 PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} ()
2881 addFatalError err =
2882 addError err >> PV (const PV_Failed)
2883 getBit ext =
2884 PV $ \ctx acc ->
2885 let b = ext `xtest` pExtsBitmap (pv_options ctx) in
2886 PV_Ok acc $! b
2887 allocateCommentsP ss = PV $ \_ s ->
2888 let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in
2889 PV_Ok s {
2890 pv_comment_q = comment_q'
2891 } (EpaComments newAnns)
2892 allocatePriorCommentsP ss = PV $ \_ s ->
2893 let (header_comments', comment_q', newAnns)
2894 = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in
2895 PV_Ok s {
2896 pv_header_comments = header_comments',
2897 pv_comment_q = comment_q'
2898 } (EpaComments newAnns)
2899 allocateFinalCommentsP ss = PV $ \_ s ->
2900 let (header_comments', comment_q', newAnns)
2901 = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in
2902 PV_Ok s {
2903 pv_header_comments = header_comments',
2904 pv_comment_q = comment_q'
2905 } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns))
2906
2907 {- Note [Parser-Validator Details]
2908 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2909 A PV computation is parametrized by some 'ParseContext' for diagnostic messages, which can be set
2910 depending on validation context. We use this in checkPattern to fix #984.
2911
2912 Consider this example, where the user has forgotten a 'do':
2913
2914 f _ = do
2915 x <- computation
2916 case () of
2917 _ ->
2918 result <- computation
2919 case () of () -> undefined
2920
2921 GHC parses it as follows:
2922
2923 f _ = do
2924 x <- computation
2925 (case () of
2926 _ ->
2927 result) <- computation
2928 case () of () -> undefined
2929
2930 Note that this fragment is parsed as a pattern:
2931
2932 case () of
2933 _ ->
2934 result
2935
2936 We attempt to detect such cases and add a hint to the diagnostic messages:
2937
2938 T984.hs:6:9:
2939 Parse error in pattern: case () of { _ -> result }
2940 Possibly caused by a missing 'do'?
2941
2942 The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed
2943 out of the 'ParseContext', which are read by functions like 'patFail' when
2944 constructing the 'PsParseErrorInPatDetails' data structure. When validating in a
2945 context other than 'bindpat' (a pattern to the left of <-), we set the
2946 details to 'noParseContext' and it has no effect on the diagnostic messages.
2947
2948 -}
2949
2950 -- | Hint about bang patterns, assuming @BangPatterns@ is off.
2951 hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
2952 hintBangPat span e = do
2953 bang_on <- getBit BangPatBit
2954 unless bang_on $
2955 addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e
2956
2957 mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)
2958 -> [AddEpAnn]
2959 -> PV (LHsExpr GhcPs)
2960
2961 -- Tuple
2962 mkSumOrTupleExpr l boxity (Tuple es) anns = do
2963 cs <- getCommentsFor (locA l)
2964 return $ L l (ExplicitTuple (EpAnn (spanAsAnchor $ locA l) anns cs) (map toTupArg es) boxity)
2965 where
2966 toTupArg :: Either (EpAnn EpaLocation) (LHsExpr GhcPs) -> HsTupArg GhcPs
2967 toTupArg (Left ann) = missingTupArg ann
2968 toTupArg (Right a) = Present noAnn a
2969
2970 -- Sum
2971 -- mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
2972 -- return $ L l (ExplicitSum noExtField alt arity e)
2973 mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do
2974 let an = case anns of
2975 [AddEpAnn AnnOpenPH o, AddEpAnn AnnClosePH c] ->
2976 AnnExplicitSum o barsp barsa c
2977 _ -> panic "mkSumOrTupleExpr"
2978 cs <- getCommentsFor (locA l)
2979 return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e)
2980 mkSumOrTupleExpr l Boxed a@Sum{} _ =
2981 addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a
2982
2983 mkSumOrTuplePat
2984 :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn]
2985 -> PV (LocatedA (PatBuilder GhcPs))
2986
2987 -- Tuple
2988 mkSumOrTuplePat l boxity (Tuple ps) anns = do
2989 ps' <- traverse toTupPat ps
2990 cs <- getCommentsFor (locA l)
2991 return $ L l (PatBuilderPat (TuplePat (EpAnn (spanAsAnchor $ locA l) anns cs) ps' boxity))
2992 where
2993 toTupPat :: Either (EpAnn EpaLocation) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs)
2994 -- Ignore the element location so that the error message refers to the
2995 -- entire tuple. See #19504 (and the discussion) for details.
2996 toTupPat p = case p of
2997 Left _ -> addFatalError $
2998 mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat
2999 Right p' -> checkLPat p'
3000
3001 -- Sum
3002 mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do
3003 p' <- checkLPat p
3004 cs <- getCommentsFor (locA l)
3005 let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs
3006 return $ L l (PatBuilderPat (SumPat an p' alt arity))
3007 mkSumOrTuplePat l Boxed a@Sum{} _ =
3008 addFatalError $
3009 mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a
3010
3011 mkLHsOpTy :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
3012 mkLHsOpTy x op y =
3013 let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y
3014 in L loc (mkHsOpTy x op y)
3015
3016 mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs
3017 mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) arr
3018 -- See #18888 for the use of (SourceText "1") above
3019 = HsLinearArrow (HsPct1 (L locOfPct1 HsTok) arr)
3020 where
3021 -- The location of "%" combined with the location of "1".
3022 locOfPct1 :: TokenLocation
3023 locOfPct1 = token_location_widenR (getLoc pct) (locA (getLoc t))
3024 mkMultTy pct t arr = HsExplicitMult pct t arr
3025
3026 mkTokenLocation :: SrcSpan -> TokenLocation
3027 mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc
3028 mkTokenLocation (RealSrcSpan r _) = TokenLoc (EpaSpan r)
3029
3030 -- Precondition: the TokenLocation has EpaSpan, never EpaDelta.
3031 token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation
3032 token_location_widenR NoTokenLoc _ = NoTokenLoc
3033 token_location_widenR tl (UnhelpfulSpan _) = tl
3034 token_location_widenR (TokenLoc (EpaSpan r1)) (RealSrcSpan r2 _) =
3035 (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2)))
3036 token_location_widenR (TokenLoc (EpaDelta _ _)) _ =
3037 -- Never happens because the parser does not produce EpaDelta.
3038 panic "token_location_widenR: EpaDelta"
3039
3040
3041 -----------------------------------------------------------------------------
3042 -- Token symbols
3043
3044 starSym :: Bool -> String
3045 starSym True = "★"
3046 starSym False = "*"
3047
3048 -----------------------------------------
3049 -- Bits and pieces for RecordDotSyntax.
3050
3051 mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs)
3052 -> EpAnnCO -> LHsExpr GhcPs
3053 mkRdrGetField loc arg field anns =
3054 L loc HsGetField {
3055 gf_ext = anns
3056 , gf_expr = arg
3057 , gf_field = field
3058 }
3059
3060 mkRdrProjection :: [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] -> EpAnn AnnProjection -> HsExpr GhcPs
3061 mkRdrProjection [] _ = panic "mkRdrProjection: The impossible has happened!"
3062 mkRdrProjection flds anns =
3063 HsProjection {
3064 proj_ext = anns
3065 , proj_flds = flds
3066 }
3067
3068 mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
3069 -> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn]
3070 -> LHsRecProj GhcPs (LHsExpr GhcPs)
3071 mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!"
3072 mkRdrProjUpdate loc (L l flds) arg isPun anns =
3073 L loc HsFieldBind {
3074 hfbAnn = anns
3075 , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds)
3076 , hfbRHS = arg
3077 , hfbPun = isPun
3078 }