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