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