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