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