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