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