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