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