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