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