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