aed5c5d4bb1ed1a68f86f0ebc5859201d0190285
[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
12 module RdrHsSyn (
13 mkHsOpApp,
14 mkHsIntegral, mkHsFractional, mkHsIsString,
15 mkHsDo, mkSpliceDecl,
16 mkRoleAnnotDecl,
17 mkClassDecl,
18 mkTyData, mkDataFamInst,
19 mkTySynonym, mkTyFamInstEqn,
20 mkTyFamInst,
21 mkFamDecl, mkLHsSigType,
22 splitCon, mkInlinePragma,
23 mkPatSynMatchGroup,
24 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
25 mkTyClD, mkInstD,
26 mkRdrRecordCon, mkRdrRecordUpd,
27 setRdrNameSpace,
28
29 cvBindGroup,
30 cvBindsAndSigs,
31 cvTopDecls,
32 placeHolderPunRhs,
33
34 -- Stuff to do with Foreign declarations
35 mkImport,
36 parseCImport,
37 mkExport,
38 mkExtName, -- RdrName -> CLabelString
39 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
40 mkConDeclH98,
41 mkATDefault,
42
43 -- Bunch of functions in the parser monad for
44 -- checking and constructing values
45 checkBlockArguments,
46 checkPrecP, -- Int -> P Int
47 checkContext, -- HsType -> P HsContext
48 checkInfixConstr,
49 checkPattern, -- HsExp -> P HsPat
50 bang_RDR,
51 checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
52 checkMonadComp, -- P (HsStmtContext RdrName)
53 checkCommand, -- LHsExpr RdrName -> P (LHsCmd RdrName)
54 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
55 checkValSigLhs,
56 checkDoAndIfThenElse,
57 checkRecordSyntax,
58 checkEmptyGADTs,
59 parseErrorSDoc, hintBangPat,
60 splitTilde,
61 TyEl(..), mergeOps,
62
63 -- Help with processing exports
64 ImpExpSubSpec(..),
65 ImpExpQcSpec(..),
66 mkModuleImpExp,
67 mkTypeImpExp,
68 mkImpExpSubSpec,
69 checkImportSpec,
70
71 -- Warnings and errors
72 warnStarIsType,
73 failOpFewArgs,
74
75 SumOrTuple (..), mkSumOrTuple
76
77 ) where
78
79 import GhcPrelude
80 import HsSyn -- Lots of it
81 import Class ( FunDep )
82 import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
83 import DataCon ( DataCon, dataConTyCon )
84 import ConLike ( ConLike(..) )
85 import CoAxiom ( Role, fsFromRole )
86 import RdrName
87 import Name
88 import BasicTypes
89 import TcEvidence ( idHsWrapper )
90 import Lexer
91 import Lexeme ( isLexCon )
92 import Type ( TyThing(..) )
93 import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon,
94 nilDataConName, nilDataConKey,
95 listTyConName, listTyConKey )
96 import ForeignCall
97 import PrelNames ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
98 import SrcLoc
99 import Unique ( hasKey )
100 import OrdList ( OrdList, fromOL )
101 import Bag ( emptyBag, consBag )
102 import Outputable
103 import FastString
104 import Maybes
105 import Util
106 import ApiAnnotation
107 import HsExtension ( noExt )
108 import Data.List
109 import qualified GHC.LanguageExtensions as LangExt
110 import DynFlags ( WarningFlag(..) )
111
112 import Control.Monad
113 import Text.ParserCombinators.ReadP as ReadP
114 import Data.Char
115
116 import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
117
118 #include "HsVersions.h"
119
120
121 {- **********************************************************************
122
123 Construction functions for Rdr stuff
124
125 ********************************************************************* -}
126
127 -- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and
128 -- datacon by deriving them from the name of the class. We fill in the names
129 -- for the tycon and datacon corresponding to the class, by deriving them
130 -- from the name of the class itself. This saves recording the names in the
131 -- interface file (which would be equally good).
132
133 -- Similarly for mkConDecl, mkClassOpSig and default-method names.
134
135 -- *** See Note [The Naming story] in HsDecls ****
136
137 mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
138 mkTyClD (L loc d) = L loc (TyClD noExt d)
139
140 mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
141 mkInstD (L loc d) = L loc (InstD noExt d)
142
143 mkClassDecl :: SrcSpan
144 -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
145 -> Located (a,[Located (FunDep (Located RdrName))])
146 -> OrdList (LHsDecl GhcPs)
147 -> P (LTyClDecl GhcPs)
148
149 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
150 = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
151 ; let cxt = fromMaybe (noLoc []) mcxt
152 ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
153 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
154 ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
155 ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
156 ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
157 , tcdLName = cls, tcdTyVars = tyvars
158 , tcdFixity = fixity
159 , tcdFDs = snd (unLoc fds)
160 , tcdSigs = mkClassOpSigs sigs
161 , tcdMeths = binds
162 , tcdATs = ats, tcdATDefs = at_defs
163 , tcdDocs = docs })) }
164
165 mkATDefault :: LTyFamInstDecl GhcPs
166 -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs)
167 -- Take a type-family instance declaration and turn it into
168 -- a type-family default equation for a class declaration
169 -- We parse things as the former and use this function to convert to the latter
170 --
171 -- We use the Either monad because this also called
172 -- from Convert.hs
173 mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
174 | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
175 , feqn_rhs = rhs } <- e
176 = do { tvs <- checkTyVars (text "default") equalsDots tc pats
177 ; return (L loc (FamEqn { feqn_ext = noExt
178 , feqn_tycon = tc
179 , feqn_pats = tvs
180 , feqn_fixity = fixity
181 , feqn_rhs = rhs })) }
182 mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
183 mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
184
185 mkTyData :: SrcSpan
186 -> NewOrData
187 -> Maybe (Located CType)
188 -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
189 -> Maybe (LHsKind GhcPs)
190 -> [LConDecl GhcPs]
191 -> HsDeriving GhcPs
192 -> P (LTyClDecl GhcPs)
193 mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
194 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
195 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
196 ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
197 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
198 ; return (L loc (DataDecl { tcdDExt = noExt,
199 tcdLName = tc, tcdTyVars = tyvars,
200 tcdFixity = fixity,
201 tcdDataDefn = defn })) }
202
203 mkDataDefn :: NewOrData
204 -> Maybe (Located CType)
205 -> Maybe (LHsContext GhcPs)
206 -> Maybe (LHsKind GhcPs)
207 -> [LConDecl GhcPs]
208 -> HsDeriving GhcPs
209 -> P (HsDataDefn GhcPs)
210 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
211 = do { checkDatatypeContext mcxt
212 ; let cxt = fromMaybe (noLoc []) mcxt
213 ; return (HsDataDefn { dd_ext = noExt
214 , dd_ND = new_or_data, dd_cType = cType
215 , dd_ctxt = cxt
216 , dd_cons = data_cons
217 , dd_kindSig = ksig
218 , dd_derivs = maybe_deriv }) }
219
220
221 mkTySynonym :: SrcSpan
222 -> LHsType GhcPs -- LHS
223 -> LHsType GhcPs -- RHS
224 -> P (LTyClDecl GhcPs)
225 mkTySynonym loc lhs rhs
226 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
227 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
228 ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
229 ; return (L loc (SynDecl { tcdSExt = noExt
230 , tcdLName = tc, tcdTyVars = tyvars
231 , tcdFixity = fixity
232 , tcdRhs = rhs })) }
233
234 mkTyFamInstEqn :: LHsType GhcPs
235 -> LHsType GhcPs
236 -> P (TyFamInstEqn GhcPs,[AddAnn])
237 mkTyFamInstEqn lhs rhs
238 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
239 ; return (mkHsImplicitBndrs
240 (FamEqn { feqn_ext = noExt
241 , feqn_tycon = tc
242 , feqn_pats = tparams
243 , feqn_fixity = fixity
244 , feqn_rhs = rhs }),
245 ann) }
246
247 mkDataFamInst :: SrcSpan
248 -> NewOrData
249 -> Maybe (Located CType)
250 -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
251 -> Maybe (LHsKind GhcPs)
252 -> [LConDecl GhcPs]
253 -> HsDeriving GhcPs
254 -> P (LInstDecl GhcPs)
255 mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
256 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
257 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
258 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
259 ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
260 (FamEqn { feqn_ext = noExt
261 , feqn_tycon = tc
262 , feqn_pats = tparams
263 , feqn_fixity = fixity
264 , feqn_rhs = defn }))))) }
265
266 mkTyFamInst :: SrcSpan
267 -> TyFamInstEqn GhcPs
268 -> P (LInstDecl GhcPs)
269 mkTyFamInst loc eqn
270 = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn)))
271
272 mkFamDecl :: SrcSpan
273 -> FamilyInfo GhcPs
274 -> LHsType GhcPs -- LHS
275 -> Located (FamilyResultSig GhcPs) -- Optional result signature
276 -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation
277 -> P (LTyClDecl GhcPs)
278 mkFamDecl loc info lhs ksig injAnn
279 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
280 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
281 ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
282 ; return (L loc (FamDecl noExt (FamilyDecl
283 { fdExt = noExt
284 , fdInfo = info, fdLName = tc
285 , fdTyVars = tyvars
286 , fdFixity = fixity
287 , fdResultSig = ksig
288 , fdInjectivityAnn = injAnn }))) }
289 where
290 equals_or_where = case info of
291 DataFamily -> empty
292 OpenTypeFamily -> empty
293 ClosedTypeFamily {} -> whereDots
294
295 mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
296 -- If the user wrote
297 -- [pads| ... ] then return a QuasiQuoteD
298 -- $(e) then return a SpliceD
299 -- but if she wrote, say,
300 -- f x then behave as if she'd written $(f x)
301 -- ie a SpliceD
302 --
303 -- Typed splices are not allowed at the top level, thus we do not represent them
304 -- as spliced declaration. See #10945
305 mkSpliceDecl lexpr@(L loc expr)
306 | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
307 = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
308
309 | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
310 = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
311
312 | otherwise
313 = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr))
314 ImplicitSplice)
315
316 mkRoleAnnotDecl :: SrcSpan
317 -> Located RdrName -- type being annotated
318 -> [Located (Maybe FastString)] -- roles
319 -> P (LRoleAnnotDecl GhcPs)
320 mkRoleAnnotDecl loc tycon roles
321 = do { roles' <- mapM parse_role roles
322 ; return $ L loc $ RoleAnnotDecl noExt tycon roles' }
323 where
324 role_data_type = dataTypeOf (undefined :: Role)
325 all_roles = map fromConstr $ dataTypeConstrs role_data_type
326 possible_roles = [(fsFromRole role, role) | role <- all_roles]
327
328 parse_role (L loc_role Nothing) = return $ L loc_role Nothing
329 parse_role (L loc_role (Just role))
330 = case lookup role possible_roles of
331 Just found_role -> return $ L loc_role $ Just found_role
332 Nothing ->
333 let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
334 parseErrorSDoc loc_role
335 (text "Illegal role name" <+> quotes (ppr role) $$
336 suggestions nearby)
337
338 suggestions [] = empty
339 suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r)
340 -- will this last case ever happen??
341 suggestions list = hang (text "Perhaps you meant one of these:")
342 2 (pprWithCommas (quotes . ppr) list)
343
344 {- **********************************************************************
345
346 #cvBinds-etc# Converting to @HsBinds@, etc.
347
348 ********************************************************************* -}
349
350 -- | Function definitions are restructured here. Each is assumed to be recursive
351 -- initially, and non recursive definitions are discovered by the dependency
352 -- analyser.
353
354
355 -- | Groups together bindings for a single function
356 cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
357 cvTopDecls decls = go (fromOL decls)
358 where
359 go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
360 go [] = []
361 go (L l (ValD x b) : ds) = L l' (ValD x b') : go ds'
362 where (L l' b', ds') = getMonoBind (L l b) ds
363 go (d : ds) = d : go ds
364
365 -- Declaration list may only contain value bindings and signatures.
366 cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
367 cvBindGroup binding
368 = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
369 ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
370 return $ ValBinds noExt mbs sigs }
371
372 cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
373 -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
374 , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
375 -- Input decls contain just value bindings and signatures
376 -- and in case of class or instance declarations also
377 -- associated type declarations. They might also contain Haddock comments.
378 cvBindsAndSigs fb = go (fromOL fb)
379 where
380 go [] = return (emptyBag, [], [], [], [], [])
381 go (L l (ValD _ b) : ds)
382 = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
383 ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
384 where
385 (b', ds') = getMonoBind (L l b) ds
386 go (L l decl : ds)
387 = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
388 ; case decl of
389 SigD _ s
390 -> return (bs, L l s : ss, ts, tfis, dfis, docs)
391 TyClD _ (FamDecl _ t)
392 -> return (bs, ss, L l t : ts, tfis, dfis, docs)
393 InstD _ (TyFamInstD { tfid_inst = tfi })
394 -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
395 InstD _ (DataFamInstD { dfid_inst = dfi })
396 -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
397 DocD _ d
398 -> return (bs, ss, ts, tfis, dfis, L l d : docs)
399 SpliceD _ d
400 -> parseErrorSDoc l $
401 hang (text "Declaration splices are allowed only" <+>
402 text "at the top level:")
403 2 (ppr d)
404 _ -> pprPanic "cvBindsAndSigs" (ppr decl) }
405
406 -----------------------------------------------------------------------------
407 -- Group function bindings into equation groups
408
409 getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
410 -> (LHsBind GhcPs, [LHsDecl GhcPs])
411 -- Suppose (b',ds') = getMonoBind b ds
412 -- ds is a list of parsed bindings
413 -- b is a MonoBinds that has just been read off the front
414
415 -- Then b' is the result of grouping more equations from ds that
416 -- belong with b into a single MonoBinds, and ds' is the depleted
417 -- list of parsed bindings.
418 --
419 -- All Haddock comments between equations inside the group are
420 -- discarded.
421 --
422 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
423
424 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
425 fun_matches
426 = MG { mg_alts = L _ mtchs1 } })) binds
427 | has_args mtchs1
428 = go mtchs1 loc1 binds []
429 where
430 go mtchs loc
431 (L loc2 (ValD _ (FunBind { fun_id = L _ f2,
432 fun_matches
433 = MG { mg_alts = L _ mtchs2 } })) : binds) _
434 | f1 == f2 = go (mtchs2 ++ mtchs)
435 (combineSrcSpans loc loc2) binds []
436 go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
437 = let doc_decls' = doc_decl : doc_decls
438 in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
439 go mtchs loc binds doc_decls
440 = ( L loc (makeFunBind fun_id1 (reverse mtchs))
441 , (reverse doc_decls) ++ binds)
442 -- Reverse the final matches, to get it back in the right order
443 -- Do the same thing with the trailing doc comments
444
445 getMonoBind bind binds = (bind, binds)
446
447 has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
448 has_args [] = panic "RdrHsSyn:has_args"
449 has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
450 -- Don't group together FunBinds if they have
451 -- no arguments. This is necessary now that variable bindings
452 -- with no arguments are now treated as FunBinds rather
453 -- than pattern bindings (tests/rename/should_fail/rnfail002).
454 has_args ((L _ (XMatch _)) : _) = panic "has_args"
455
456 {- **********************************************************************
457
458 #PrefixToHS-utils# Utilities for conversion
459
460 ********************************************************************* -}
461
462 {- Note [Parsing data constructors is hard]
463 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
464 We parse the RHS of the constructor declaration
465 data T = C t1 t2
466 as a btype_no_ops (treating C as a type constructor) and then convert C to be
467 a data constructor. Reason: it might continue like this:
468 data T = C t1 t2 :% D Int
469 in which case C really /would/ be a type constructor. We can't resolve this
470 ambiguity till we come across the constructor oprerator :% (or not, more usually)
471
472 So the plan is:
473
474 * Parse the data constructor declration as a type (actually btype_no_ops)
475
476 * Use 'splitCon' to rejig it into the data constructor, the args, and possibly
477 extract a docstring for the constructor
478
479 * In doing so, we use 'tyConToDataCon' to convert the RdrName for
480 the data con, which has been parsed as a tycon, back to a datacon.
481 This is more than just adjusting the name space; for operators we
482 need to check that it begins with a colon. E.g.
483 data T = (+++)
484 will parse ok (since tycons can be operators), but we should reject
485 it (Trac #12051).
486
487 'splitCon' takes a reversed list @apps@ of types as input, such that
488 @foldl1 mkHsAppTy (reverse apps)@ yields the original type. This is because
489 this is easy for the parser to produce and we avoid the overhead of unrolling
490 'HsAppTy'.
491
492 -}
493
494 splitCon :: [LHsType GhcPs]
495 -> P ( Located RdrName -- constructor name
496 , HsConDeclDetails GhcPs -- constructor field information
497 , Maybe LHsDocString -- docstring to go on the constructor
498 )
499 -- See Note [Parsing data constructors is hard]
500 -- This gets given a "type" that should look like
501 -- C Int Bool
502 -- or C { x::Int, y::Bool }
503 -- and returns the pieces
504 splitCon apps
505 = split apps' []
506 where
507 oneDoc = [ () | L _ (HsDocTy{}) <- apps ] `lengthIs` 1
508 ty = foldl1 mkHsAppTy (reverse apps)
509
510 -- the trailing doc, if any, can be extracted first
511 (apps', trailing_doc)
512 = case apps of
513 L _ (HsDocTy _ t ds) : ts | oneDoc -> (t : ts, Just ds)
514 ts -> (ts, Nothing)
515
516 -- A comment on the constructor is handled a bit differently - it doesn't
517 -- remain an 'HsDocTy', but gets lifted out and returned as the third
518 -- element of the tuple.
519 split [ L _ (HsDocTy _ con con_doc) ] ts = do
520 (data_con, con_details, con_doc') <- split [con] ts
521 return (data_con, con_details, con_doc' `mplus` Just con_doc)
522 split [ L l (HsTyVar _ _ (L _ tc)) ] ts = do
523 data_con <- tyConToDataCon l tc
524 return (data_con, mk_rest ts, trailing_doc)
525 split [ L l (HsTupleTy _ HsBoxedOrConstraintTuple ts) ] []
526 = return ( L l (getRdrName (tupleDataCon Boxed (length ts)))
527 , PrefixCon ts
528 , trailing_doc
529 )
530 split [ L l _ ] _ = parseErrorSDoc l (text msg <+> ppr ty)
531 where msg = "Cannot parse data constructor in a data/newtype declaration:"
532 split (u : us) ts = split us (u : ts)
533 split _ _ = panic "RdrHsSyn:splitCon"
534
535 mk_rest [L _ (HsDocTy _ t@(L _ HsRecTy{}) _)] = mk_rest [t]
536 mk_rest [L l (HsRecTy _ flds)] = RecCon (L l flds)
537 mk_rest ts = PrefixCon ts
538
539 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
540 -- See Note [Parsing data constructors is hard]
541 -- Data constructor RHSs are parsed as types
542 tyConToDataCon loc tc
543 | isTcOcc occ
544 , isLexCon (occNameFS occ)
545 = return (L loc (setRdrNameSpace tc srcDataName))
546
547 | otherwise
548 = parseErrorSDoc loc (msg $$ extra)
549 where
550 occ = rdrNameOcc tc
551
552 msg = text "Not a data constructor:" <+> quotes (ppr tc)
553 extra | tc == forall_tv_RDR
554 = text "Perhaps you intended to use ExistentialQuantification"
555 | otherwise = empty
556
557 -- | Split a type to extract the trailing doc string (if there is one) from a
558 -- type produced by the 'btype_no_ops' production.
559 splitDocTy :: LHsType GhcPs -> (LHsType GhcPs, Maybe LHsDocString)
560 splitDocTy (L l (HsAppTy x t1 t2)) = (L l (HsAppTy x t1 t2'), ds)
561 where ~(t2', ds) = splitDocTy t2
562 splitDocTy (L _ (HsDocTy _ ty ds)) = (ty, Just ds)
563 splitDocTy ty = (ty, Nothing)
564
565 -- | Given a type that is a field to an infix data constructor, try to split
566 -- off a trailing docstring on the type, and check that there are no other
567 -- docstrings.
568 checkInfixConstr :: LHsType GhcPs -> P (LHsType GhcPs, Maybe LHsDocString)
569 checkInfixConstr ty = checkNoDocs msg ty' *> pure (ty', doc_string)
570 where (ty', doc_string) = splitDocTy ty
571 msg = text "infix constructor field"
572
573 mkPatSynMatchGroup :: Located RdrName
574 -> Located (OrdList (LHsDecl GhcPs))
575 -> P (MatchGroup GhcPs (LHsExpr GhcPs))
576 mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
577 do { matches <- mapM fromDecl (fromOL decls)
578 ; when (null matches) (wrongNumberErr loc)
579 ; return $ mkMatchGroup FromSource matches }
580 where
581 fromDecl (L loc decl@(ValD _ (PatBind _
582 pat@(L _ (ConPatIn ln@(L _ name) details))
583 rhs _))) =
584 do { unless (name == patsyn_name) $
585 wrongNameBindingErr loc decl
586 ; match <- case details of
587 PrefixCon pats -> return $ Match { m_ext = noExt
588 , m_ctxt = ctxt, m_pats = pats
589 , m_grhss = rhs }
590 where
591 ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict }
592
593 InfixCon p1 p2 -> return $ Match { m_ext = noExt
594 , m_ctxt = ctxt
595 , m_pats = [p1, p2]
596 , m_grhss = rhs }
597 where
598 ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }
599
600 RecCon{} -> recordPatSynErr loc pat
601 ; return $ L loc match }
602 fromDecl (L loc decl) = extraDeclErr loc decl
603
604 extraDeclErr loc decl =
605 parseErrorSDoc loc $
606 text "pattern synonym 'where' clause must contain a single binding:" $$
607 ppr decl
608
609 wrongNameBindingErr loc decl =
610 parseErrorSDoc loc $
611 text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
612 quotes (ppr patsyn_name) $$ ppr decl
613
614 wrongNumberErr loc =
615 parseErrorSDoc loc $
616 text "pattern synonym 'where' clause cannot be empty" $$
617 text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
618
619 recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
620 recordPatSynErr loc pat =
621 parseErrorSDoc loc $
622 text "record syntax not supported for pattern synonym declarations:" $$
623 ppr pat
624
625 mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
626 -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
627 -> ConDecl GhcPs
628
629 mkConDeclH98 name mb_forall mb_cxt args
630 = ConDeclH98 { con_ext = noExt
631 , con_name = name
632 , con_forall = noLoc $ isJust mb_forall
633 , con_ex_tvs = mb_forall `orElse` []
634 , con_mb_cxt = mb_cxt
635 , con_args = args'
636 , con_doc = Nothing }
637 where
638 args' = nudgeHsSrcBangs args
639
640 mkGadtDecl :: [Located RdrName]
641 -> LHsType GhcPs -- Always a HsForAllTy
642 -> (ConDecl GhcPs, [AddAnn])
643 mkGadtDecl names ty
644 = (ConDeclGADT { con_g_ext = noExt
645 , con_names = names
646 , con_forall = L l $ isLHsForAllTy ty
647 , con_qvars = mkHsQTvs tvs
648 , con_mb_cxt = mcxt
649 , con_args = args'
650 , con_res_ty = res_ty
651 , con_doc = Nothing }
652 , anns1 ++ anns2 ++ anns3)
653 where
654 (ty'@(L l _),anns1) = peel_parens ty []
655 (tvs, rho) = splitLHsForAllTy ty'
656 (mcxt, tau, anns2) = split_rho rho []
657
658 split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
659 = (Just cxt, tau, ann)
660 split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
661 split_rho tau ann = (Nothing, tau, ann)
662
663 (args, res_ty, anns3) = split_tau tau []
664 args' = nudgeHsSrcBangs args
665
666 -- See Note [GADT abstract syntax] in HsDecls
667 split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty)) ann
668 = (RecCon (L loc rf), res_ty, ann)
669 split_tau (L l (HsParTy _ ty)) ann = split_tau ty (ann++mkParensApiAnn l)
670 split_tau tau ann = (PrefixCon [], tau, ann)
671
672 peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
673 (ann++mkParensApiAnn l)
674 peel_parens ty ann = (ty, ann)
675
676 nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
677 -- ^ This function ensures that fields with strictness or packedness
678 -- annotations put these annotations on an outer 'HsBangTy'.
679 --
680 -- The problem is that in the parser, strictness and packedness annotations
681 -- bind more tightly that docstrings. However, the expectation downstream of
682 -- the parser (by functions such as 'getBangType' and 'getBangStrictness')
683 -- is that docstrings bind more tightly so that 'HsBangTy' may end up as the
684 -- top-level type.
685 --
686 -- See #15206
687 nudgeHsSrcBangs details
688 = case details of
689 PrefixCon as -> PrefixCon (map go as)
690 RecCon r -> RecCon r
691 InfixCon a1 a2 -> InfixCon (go a1) (go a2)
692 where
693 go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) =
694 L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
695 go lty = lty
696
697
698 setRdrNameSpace :: RdrName -> NameSpace -> RdrName
699 -- ^ This rather gruesome function is used mainly by the parser.
700 -- When parsing:
701 --
702 -- > data T a = T | T1 Int
703 --
704 -- we parse the data constructors as /types/ because of parser ambiguities,
705 -- so then we need to change the /type constr/ to a /data constr/
706 --
707 -- The exact-name case /can/ occur when parsing:
708 --
709 -- > data [] a = [] | a : [a]
710 --
711 -- For the exact-name case we return an original name.
712 setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
713 setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
714 setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
715 setRdrNameSpace (Exact n) ns
716 | Just thing <- wiredInNameTyThing_maybe n
717 = setWiredInNameSpace thing ns
718 -- Preserve Exact Names for wired-in things,
719 -- notably tuples and lists
720
721 | isExternalName n
722 = Orig (nameModule n) occ
723
724 | otherwise -- This can happen when quoting and then
725 -- splicing a fixity declaration for a type
726 = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
727 where
728 occ = setOccNameSpace ns (nameOccName n)
729
730 setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
731 setWiredInNameSpace (ATyCon tc) ns
732 | isDataConNameSpace ns
733 = ty_con_data_con tc
734 | isTcClsNameSpace ns
735 = Exact (getName tc) -- No-op
736
737 setWiredInNameSpace (AConLike (RealDataCon dc)) ns
738 | isTcClsNameSpace ns
739 = data_con_ty_con dc
740 | isDataConNameSpace ns
741 = Exact (getName dc) -- No-op
742
743 setWiredInNameSpace thing ns
744 = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)
745
746 ty_con_data_con :: TyCon -> RdrName
747 ty_con_data_con tc
748 | isTupleTyCon tc
749 , Just dc <- tyConSingleDataCon_maybe tc
750 = Exact (getName dc)
751
752 | tc `hasKey` listTyConKey
753 = Exact nilDataConName
754
755 | otherwise -- See Note [setRdrNameSpace for wired-in names]
756 = Unqual (setOccNameSpace srcDataName (getOccName tc))
757
758 data_con_ty_con :: DataCon -> RdrName
759 data_con_ty_con dc
760 | let tc = dataConTyCon dc
761 , isTupleTyCon tc
762 = Exact (getName tc)
763
764 | dc `hasKey` nilDataConKey
765 = Exact listTyConName
766
767 | otherwise -- See Note [setRdrNameSpace for wired-in names]
768 = Unqual (setOccNameSpace tcClsName (getOccName dc))
769
770
771 {- Note [setRdrNameSpace for wired-in names]
772 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
773 In GHC.Types, which declares (:), we have
774 infixr 5 :
775 The ambiguity about which ":" is meant is resolved by parsing it as a
776 data constructor, but then using dataTcOccs to try the type constructor too;
777 and that in turn calls setRdrNameSpace to change the name-space of ":" to
778 tcClsName. There isn't a corresponding ":" type constructor, but it's painful
779 to make setRdrNameSpace partial, so we just make an Unqual name instead. It
780 really doesn't matter!
781 -}
782
783 checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
784 -> P (LHsQTyVars GhcPs)
785 -- Same as checkTyVars, but in the P monad
786 checkTyVarsP pp_what equals_or_where tc tparms
787 = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
788
789 eitherToP :: Either (SrcSpan, SDoc) a -> P a
790 -- Adapts the Either monad to the P monad
791 eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
792 eitherToP (Right thing) = return thing
793
794 checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
795 -> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs)
796 -- Check whether the given list of type parameters are all type variables
797 -- (possibly with a kind signature)
798 -- We use the Either monad because it's also called (via mkATDefault) from
799 -- Convert.hs
800 checkTyVars pp_what equals_or_where tc tparms
801 = do { tvs <- mapM chk tparms
802 ; return (mkHsQTvs tvs) }
803 where
804 chk (L _ (HsParTy _ ty)) = chk ty
805
806 -- Check that the name space is correct!
807 chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
808 | isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k))
809 chk (L l (HsTyVar _ _ (L ltv tv)))
810 | isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv)))
811 chk t@(L loc _)
812 = Left (loc,
813 vcat [ text "Unexpected type" <+> quotes (ppr t)
814 , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
815 , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form"))
816 , nest 2 (pp_what <+> ppr tc
817 <+> hsep (map text (takeList tparms allNameStrings))
818 <+> equals_or_where) ] ])
819
820 whereDots, equalsDots :: SDoc
821 -- Second argument to checkTyVars
822 whereDots = text "where ..."
823 equalsDots = text "= ..."
824
825 checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
826 checkDatatypeContext Nothing = return ()
827 checkDatatypeContext (Just (L loc c))
828 = do allowed <- extension datatypeContextsEnabled
829 unless allowed $
830 parseErrorSDoc loc
831 (text "Illegal datatype context (use DatatypeContexts):" <+>
832 pprHsContext c)
833
834 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
835 checkRecordSyntax lr@(L loc r)
836 = do allowed <- extension traditionalRecordSyntaxEnabled
837 if allowed
838 then return lr
839 else parseErrorSDoc loc
840 (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
841 ppr r)
842
843 -- | Check if the gadt_constrlist is empty. Only raise parse error for
844 -- `data T where` to avoid affecting existing error message, see #8258.
845 checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
846 -> P (Located ([AddAnn], [LConDecl GhcPs]))
847 checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration.
848 = do opts <- fmap options getPState
849 if LangExt.GADTSyntax `extopt` opts -- GADTs implies GADTSyntax
850 then return gadts
851 else parseErrorSDoc span $ vcat
852 [ text "Illegal keyword 'where' in data declaration"
853 , text "Perhaps you intended to use GADTs or a similar language"
854 , text "extension to enable syntax: data T where"
855 ]
856 checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration.
857
858 checkTyClHdr :: Bool -- True <=> class header
859 -- False <=> type header
860 -> LHsType GhcPs
861 -> P (Located RdrName, -- the head symbol (type or class name)
862 [LHsType GhcPs], -- parameters of head symbol
863 LexicalFixity, -- the declaration is in infix format
864 [AddAnn]) -- API Annotation for HsParTy when stripping parens
865 -- Well-formedness check and decomposition of type and class heads.
866 -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
867 -- Int :*: Bool into (:*:, [Int, Bool])
868 -- returning the pieces
869 checkTyClHdr is_cls ty
870 = goL ty [] [] Prefix
871 where
872 goL (L l ty) acc ann fix = go l ty acc ann fix
873
874 -- workaround to define '*' despite StarIsType
875 go _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
876 = do { warnStarBndr l
877 ; let name = mkOccName tcClsName (if isUni then "★" else "*")
878 ; return (L l (Unqual name), acc, fix, ann) }
879
880 go l (HsTyVar _ _ (L _ tc)) acc ann fix
881 | isRdrTc tc = return (L l tc, acc, fix, ann)
882 go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
883 | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann)
884 go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
885 go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
886
887 go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
888 = return (L l (nameRdrName tup_name), ts, fix, ann)
889 where
890 arity = length ts
891 tup_name | is_cls = cTupleTyConName arity
892 | otherwise = getName (tupleTyCon Boxed arity)
893 -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?)
894 go l _ _ _ _
895 = parseErrorSDoc l (text "Malformed head of type or class declaration:"
896 <+> ppr ty)
897
898 -- | Yield a parse error if we have a function applied directly to a do block
899 -- etc. and BlockArguments is not enabled.
900 checkBlockArguments :: LHsExpr GhcPs -> P ()
901 checkBlockArguments expr = case unLoc expr of
902 HsDo _ DoExpr _ -> check "do block"
903 HsDo _ MDoExpr _ -> check "mdo block"
904 HsLam {} -> check "lambda expression"
905 HsCase {} -> check "case expression"
906 HsLamCase {} -> check "lambda-case expression"
907 HsLet {} -> check "let expression"
908 HsIf {} -> check "if expression"
909 HsProc {} -> check "proc expression"
910 _ -> return ()
911 where
912 check element = do
913 pState <- getPState
914 unless (extopt LangExt.BlockArguments (options pState)) $
915 parseErrorSDoc (getLoc expr) $
916 text "Unexpected " <> text element <> text " in function application:"
917 $$ nest 4 (ppr expr)
918 $$ text "You could write it with parentheses"
919 $$ text "Or perhaps you meant to enable BlockArguments?"
920
921 -- | Validate the context constraints and break up a context into a list
922 -- of predicates.
923 --
924 -- @
925 -- (Eq a, Ord b) --> [Eq a, Ord b]
926 -- Eq a --> [Eq a]
927 -- (Eq a) --> [Eq a]
928 -- (((Eq a))) --> [Eq a]
929 -- @
930 checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
931 checkContext (L l orig_t)
932 = check [] (L l orig_t)
933 where
934 check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
935 -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
936 -- be used as context constraints.
937 = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
938
939 check anns (L lp1 (HsParTy _ ty))
940 -- to be sure HsParTy doesn't get into the way
941 = check anns' ty
942 where anns' = if l == lp1 then anns
943 else (anns ++ mkParensApiAnn lp1)
944
945 -- no need for anns, returning original
946 check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t])
947
948 msg = text "data constructor context"
949
950 -- | Check recursively if there are any 'HsDocTy's in the given type.
951 -- This only works on a subset of types produced by 'btype_no_ops'
952 checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
953 checkNoDocs msg ty = go ty
954 where
955 go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
956 go (L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
957 [ text "Unexpected haddock", quotes (ppr ds)
958 , text "on", msg, quotes (ppr t) ]
959 go _ = pure ()
960
961 -- -------------------------------------------------------------------------
962 -- Checking Patterns.
963
964 -- We parse patterns as expressions and check for valid patterns below,
965 -- converting the expression into a pattern at the same time.
966
967 checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
968 checkPattern msg e = checkLPat msg e
969
970 checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
971 checkPatterns msg es = mapM (checkPattern msg) es
972
973 checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
974 checkLPat msg e@(L l _) = checkPat msg l e []
975
976 checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
977 -> P (LPat GhcPs)
978 checkPat _ loc (L l e@(HsVar _ (L _ c))) args
979 | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
980 | not (null args) && patIsRec c =
981 patFail (text "Perhaps you intended to use RecursiveDo") l e
982 checkPat msg loc e args -- OK to let this happen even if bang-patterns
983 -- are not enabled, because there is no valid
984 -- non-bang-pattern parse of (C ! e)
985 | Just (e', args') <- splitBang e
986 = do { args'' <- checkPatterns msg args'
987 ; checkPat msg loc e' (args'' ++ args) }
988 checkPat msg loc (L _ (HsApp _ f e)) args
989 = do p <- checkLPat msg e
990 checkPat msg loc f (p : args)
991 checkPat msg loc (L _ e) []
992 = do p <- checkAPat msg loc e
993 return (L loc p)
994 checkPat msg loc e _
995 = patFail msg loc (unLoc e)
996
997 checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
998 checkAPat msg loc e0 = do
999 pState <- getPState
1000 let opts = options pState
1001 case e0 of
1002 EWildPat _ -> return (WildPat noExt)
1003 HsVar _ x -> return (VarPat noExt x)
1004 HsLit _ (HsStringPrim _ _) -- (#13260)
1005 -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)
1006
1007 HsLit _ l -> return (LitPat noExt l)
1008
1009 -- Overloaded numeric patterns (e.g. f 0 x = x)
1010 -- Negation is recorded separately, so that the literal is zero or +ve
1011 -- NB. Negative *primitive* literals are already handled by the lexer
1012 HsOverLit _ pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
1013 NegApp _ (L l (HsOverLit _ pos_lit)) _
1014 -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
1015
1016 SectionR _ (L lb (HsVar _ (L _ bang))) e -- (! x)
1017 | bang == bang_RDR
1018 -> do { hintBangPat loc e0
1019 ; e' <- checkLPat msg e
1020 ; addAnnotation loc AnnBang lb
1021 ; return (BangPat noExt e') }
1022
1023 ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt))
1024 EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n)
1025 -- view pattern is well-formed if the pattern is
1026 EViewPat _ expr patE -> checkLPat msg patE >>=
1027 (return . (\p -> ViewPat noExt expr p))
1028 ExprWithTySig t e -> do e <- checkLPat msg e
1029 return (SigPat t e)
1030
1031 -- n+k patterns
1032 OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
1033 (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
1034 | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
1035 -> return (mkNPlusKPat (L nloc n) (L lloc lit))
1036
1037 OpApp _ l (L cl (HsVar _ (L _ c))) r
1038 | isDataOcc (rdrNameOcc c) -> do
1039 l <- checkLPat msg l
1040 r <- checkLPat msg r
1041 return (ConPatIn (L cl c) (InfixCon l r))
1042
1043 OpApp {} -> patFail msg loc e0
1044
1045 ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
1046 return (ListPat noExt ps)
1047
1048 HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt))
1049
1050 ExplicitTuple _ es b
1051 | all tupArgPresent es -> do ps <- mapM (checkLPat msg)
1052 [e | L _ (Present _ e) <- es]
1053 return (TuplePat noExt ps b)
1054 | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
1055
1056 ExplicitSum _ alt arity expr -> do
1057 p <- checkLPat msg expr
1058 return (SumPat noExt p alt arity)
1059
1060 RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
1061 -> do fs <- mapM (checkPatField msg) fs
1062 return (ConPatIn c (RecCon (HsRecFields fs dd)))
1063 HsSpliceE _ s | not (isTypedSplice s)
1064 -> return (SplicePat noExt s)
1065 _ -> patFail msg loc e0
1066
1067 placeHolderPunRhs :: LHsExpr GhcPs
1068 -- The RHS of a punned record field will be filled in by the renamer
1069 -- It's better not to make it an error, in case we want to print it when debugging
1070 placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR))
1071
1072 plus_RDR, bang_RDR, pun_RDR :: RdrName
1073 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
1074 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
1075 pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
1076
1077 checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
1078 -> P (LHsRecField GhcPs (LPat GhcPs))
1079 checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
1080 return (L l (fld { hsRecFieldArg = p }))
1081
1082 patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
1083 patFail msg loc e = parseErrorSDoc loc err
1084 where err = text "Parse error in pattern:" <+> ppr e
1085 $$ msg
1086
1087 patIsRec :: RdrName -> Bool
1088 patIsRec e = e == mkUnqual varName (fsLit "rec")
1089
1090
1091 ---------------------------------------------------------------------------
1092 -- Check Equation Syntax
1093
1094 checkValDef :: SDoc
1095 -> SrcStrictness
1096 -> LHsExpr GhcPs
1097 -> Maybe (LHsType GhcPs)
1098 -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
1099 -> P ([AddAnn],HsBind GhcPs)
1100
1101 checkValDef msg _strictness lhs (Just sig) grhss
1102 -- x :: ty = rhs parses as a *pattern* binding
1103 = checkPatBind msg (L (combineLocs lhs sig)
1104 (ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss
1105
1106 checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
1107 = do { mb_fun <- isFunLhs lhs
1108 ; case mb_fun of
1109 Just (fun, is_infix, pats, ann) ->
1110 checkFunBind msg strictness ann (getLoc lhs)
1111 fun is_infix pats (L l grhss)
1112 Nothing -> checkPatBind msg lhs g }
1113
1114 checkFunBind :: SDoc
1115 -> SrcStrictness
1116 -> [AddAnn]
1117 -> SrcSpan
1118 -> Located RdrName
1119 -> LexicalFixity
1120 -> [LHsExpr GhcPs]
1121 -> Located (GRHSs GhcPs (LHsExpr GhcPs))
1122 -> P ([AddAnn],HsBind GhcPs)
1123 checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
1124 = do ps <- checkPatterns msg pats
1125 let match_span = combineSrcSpans lhs_loc rhs_span
1126 -- Add back the annotations stripped from any HsPar values in the lhs
1127 -- mapM_ (\a -> a match_span) ann
1128 return (ann, makeFunBind fun
1129 [L match_span (Match { m_ext = noExt
1130 , m_ctxt = FunRhs { mc_fun = fun
1131 , mc_fixity = is_infix
1132 , mc_strictness = strictness }
1133 , m_pats = ps
1134 , m_grhss = grhss })])
1135 -- The span of the match covers the entire equation.
1136 -- That isn't quite right, but it'll do for now.
1137
1138 makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
1139 -> HsBind GhcPs
1140 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
1141 makeFunBind fn ms
1142 = FunBind { fun_ext = noExt,
1143 fun_id = fn,
1144 fun_matches = mkMatchGroup FromSource ms,
1145 fun_co_fn = idHsWrapper,
1146 fun_tick = [] }
1147
1148 checkPatBind :: SDoc
1149 -> LHsExpr GhcPs
1150 -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
1151 -> P ([AddAnn],HsBind GhcPs)
1152 checkPatBind msg lhs (L _ (_,grhss))
1153 = do { lhs <- checkPattern msg lhs
1154 ; return ([],PatBind noExt lhs grhss
1155 ([],[])) }
1156
1157 checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
1158 checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
1159 | isUnqual v
1160 , not (isDataOcc (rdrNameOcc v))
1161 = return lrdr
1162
1163 checkValSigLhs lhs@(L l _)
1164 = parseErrorSDoc l ((text "Invalid type signature:" <+>
1165 ppr lhs <+> text ":: ...")
1166 $$ text hint)
1167 where
1168 hint | foreign_RDR `looks_like` lhs
1169 = "Perhaps you meant to use ForeignFunctionInterface?"
1170 | default_RDR `looks_like` lhs
1171 = "Perhaps you meant to use DefaultSignatures?"
1172 | pattern_RDR `looks_like` lhs
1173 = "Perhaps you meant to use PatternSynonyms?"
1174 | otherwise
1175 = "Should be of form <variable> :: <type>"
1176
1177 -- A common error is to forget the ForeignFunctionInterface flag
1178 -- so check for that, and suggest. cf Trac #3805
1179 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
1180 looks_like s (L _ (HsVar _ (L _ v))) = v == s
1181 looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs
1182 looks_like _ _ = False
1183
1184 foreign_RDR = mkUnqual varName (fsLit "foreign")
1185 default_RDR = mkUnqual varName (fsLit "default")
1186 pattern_RDR = mkUnqual varName (fsLit "pattern")
1187
1188
1189 checkDoAndIfThenElse :: LHsExpr GhcPs
1190 -> Bool
1191 -> LHsExpr GhcPs
1192 -> Bool
1193 -> LHsExpr GhcPs
1194 -> P ()
1195 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
1196 | semiThen || semiElse
1197 = do pState <- getPState
1198 unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do
1199 parseErrorSDoc (combineLocs guardExpr elseExpr)
1200 (text "Unexpected semi-colons in conditional:"
1201 $$ nest 4 expr
1202 $$ text "Perhaps you meant to use DoAndIfThenElse?")
1203 | otherwise = return ()
1204 where pprOptSemi True = semi
1205 pprOptSemi False = empty
1206 expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
1207 text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
1208 text "else" <+> ppr elseExpr
1209
1210
1211 -- The parser left-associates, so there should
1212 -- not be any OpApps inside the e's
1213 splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
1214 -- Splits (f ! g a b) into (f, [(! g), a, b])
1215 splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg))
1216 | op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns)
1217 where
1218 l' = combineLocs bang arg1
1219 (arg1,argns) = split_bang r_arg []
1220 split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es)
1221 split_bang e es = (e,es)
1222 splitBang _ = Nothing
1223
1224 isFunLhs :: LHsExpr GhcPs
1225 -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn]))
1226 -- A variable binding is parsed as a FunBind.
1227 -- Just (fun, is_infix, arg_pats) if e is a function LHS
1228 --
1229 -- The whole LHS is parsed as a single expression.
1230 -- Any infix operators on the LHS will parse left-associatively
1231 -- E.g. f !x y !z
1232 -- will parse (rather strangely) as
1233 -- (f ! x y) ! z
1234 -- It's up to isFunLhs to sort out the mess
1235 --
1236 -- a .!. !b
1237
1238 isFunLhs e = go e [] []
1239 where
1240 go (L loc (HsVar _ (L _ f))) es ann
1241 | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
1242 go (L _ (HsApp _ f e)) es ann = go f (e:es) ann
1243 go (L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
1244
1245 -- Things of the form `!x` are also FunBinds
1246 -- See Note [FunBind vs PatBind]
1247 go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var)))))
1248 [] ann
1249 | bang == bang_RDR
1250 , not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann))
1251
1252 -- For infix function defns, there should be only one infix *function*
1253 -- (though there may be infix *datacons* involved too). So we don't
1254 -- need fixity info to figure out which function is being defined.
1255 -- a `K1` b `op` c `K2` d
1256 -- must parse as
1257 -- (a `K1` b) `op` (c `K2` d)
1258 -- The renamer checks later that the precedences would yield such a parse.
1259 --
1260 -- There is a complication to deal with bang patterns.
1261 --
1262 -- ToDo: what about this?
1263 -- x + 1 `op` y = ...
1264
1265 go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann
1266 | Just (e',es') <- splitBang e
1267 = do { bang_on <- extension bangPatEnabled
1268 ; if bang_on then go e' (es' ++ es) ann
1269 else return (Just (L loc' op, Infix, (l:r:es), ann)) }
1270 -- No bangs; behave just like the next case
1271 | not (isRdrDataCon op) -- We have found the function!
1272 = return (Just (L loc' op, Infix, (l:r:es), ann))
1273 | otherwise -- Infix data con; keep going
1274 = do { mb_l <- go l es ann
1275 ; case mb_l of
1276 Just (op', Infix, j : k : es', ann')
1277 -> return (Just (op', Infix, j : op_app : es', ann'))
1278 where
1279 op_app = L loc (OpApp noExt k
1280 (L loc' (HsVar noExt (L loc' op))) r)
1281 _ -> return Nothing }
1282 go _ _ _ = return Nothing
1283
1284 -- | Transform a list of 'atype' with 'strict_mark' into
1285 -- HsOpTy's of 'eqTyCon_RDR':
1286 --
1287 -- [~a, ~b, c, ~d] ==> (~a) ~ ((b c) ~ d)
1288 --
1289 -- See Note [Parsing ~]
1290 splitTilde :: [LHsType GhcPs] -> P (LHsType GhcPs)
1291 splitTilde [] = panic "splitTilde"
1292 splitTilde (x:xs) = go x xs
1293 where
1294 -- We accumulate applications in the LHS until we encounter a laziness
1295 -- annotation. For example, if we have [Foo, x, y, ~Bar, z], the 'lhs'
1296 -- accumulator will become '(Foo x) y'. Then we strip the laziness
1297 -- annotation off 'Bar' and process the tail [Bar, z] recursively.
1298 --
1299 -- This leaves us with 'lhs = (Foo x) y' and 'rhs = Bar z'.
1300 -- In case the tail contained more laziness annotations, they would be
1301 -- processed similarly. This makes '~' right-associative.
1302 go lhs [] = return lhs
1303 go lhs (x:xs)
1304 | L loc (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t) <- x
1305 = do { rhs <- splitTilde (t:xs)
1306 ; let r = mkLHsOpTy lhs (tildeOp loc) rhs
1307 ; moveAnnotations loc (getLoc r)
1308 ; return r }
1309 | otherwise
1310 = go (mkHsAppTy lhs x) xs
1311
1312 tildeOp loc = L (srcSpanFirstCharacter loc) eqTyCon_RDR
1313
1314 -- | Either an operator or an operand.
1315 data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
1316
1317 -- | Merge a /reversed/ and /non-empty/ soup of operators and operands
1318 -- into a type.
1319 --
1320 -- User input: @F x y + G a b * X@
1321 -- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F]
1322 -- Output corresponds to what the user wrote assuming all operators are of the
1323 -- same fixity and right-associative.
1324 --
1325 -- It's a bit silly that we're doing it at all, as the renamer will have to
1326 -- rearrange this, and it'd be easier to keep things separate.
1327 mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
1328 mergeOps = go [] id
1329 where
1330 -- clause (a):
1331 -- when we encounter an operator, we must have accumulated
1332 -- something for its rhs, and there must be something left
1333 -- to build its lhs.
1334 go acc ops_acc (L l (TyElOpr op):xs) =
1335 if null acc || null xs
1336 then failOpFewArgs (L l op)
1337 else do { a <- splitTilde acc
1338 ; go [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs }
1339
1340 -- clause (b):
1341 -- whenever an operand is encountered, it is added to the accumulator
1342 go acc ops_acc (L l (TyElOpd a):xs) = go (L l a:acc) ops_acc xs
1343
1344 -- clause (c):
1345 -- at this point we know that 'acc' is non-empty because
1346 -- there are three options when 'acc' can be empty:
1347 -- 1. 'mergeOps' was called with an empty list, and this
1348 -- should never happen
1349 -- 2. 'mergeOps' was called with a list where the head is an
1350 -- operator, this is handled by clause (a)
1351 -- 3. 'mergeOps' was called with a list where the head is an
1352 -- operand, this is handled by clause (b)
1353 go acc ops_acc [] =
1354 do { a <- splitTilde acc
1355 ; return (ops_acc a) }
1356
1357 ---------------------------------------------------------------------------
1358 -- Check for monad comprehensions
1359 --
1360 -- If the flag MonadComprehensions is set, return a `MonadComp' context,
1361 -- otherwise use the usual `ListComp' context
1362
1363 checkMonadComp :: P (HsStmtContext Name)
1364 checkMonadComp = do
1365 pState <- getPState
1366 return $ if extopt LangExt.MonadComprehensions (options pState)
1367 then MonadComp
1368 else ListComp
1369
1370 -- -------------------------------------------------------------------------
1371 -- Checking arrow syntax.
1372
1373 -- We parse arrow syntax as expressions and check for valid syntax below,
1374 -- converting the expression into a pattern at the same time.
1375
1376 checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
1377 checkCommand lc = locMap checkCmd lc
1378
1379 locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
1380 locMap f (L l a) = f l a >>= (\b -> return $ L l b)
1381
1382 checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
1383 checkCmd _ (HsArrApp _ e1 e2 haat b) =
1384 return $ HsCmdArrApp noExt e1 e2 haat b
1385 checkCmd _ (HsArrForm _ e mf args) =
1386 return $ HsCmdArrForm noExt e Prefix mf args
1387 checkCmd _ (HsApp _ e1 e2) =
1388 checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2)
1389 checkCmd _ (HsLam _ mg) =
1390 checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg')
1391 checkCmd _ (HsPar _ e) =
1392 checkCommand e >>= (\c -> return $ HsCmdPar noExt c)
1393 checkCmd _ (HsCase _ e mg) =
1394 checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg')
1395 checkCmd _ (HsIf _ cf ep et ee) = do
1396 pt <- checkCommand et
1397 pe <- checkCommand ee
1398 return $ HsCmdIf noExt cf ep pt pe
1399 checkCmd _ (HsLet _ lb e) =
1400 checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
1401 checkCmd _ (HsDo _ DoExpr (L l stmts)) =
1402 mapM checkCmdLStmt stmts >>=
1403 (\ss -> return $ HsCmdDo noExt (L l ss) )
1404
1405 checkCmd _ (OpApp _ eLeft op eRight) = do
1406 -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
1407 c1 <- checkCommand eLeft
1408 c2 <- checkCommand eRight
1409 let arg1 = L (getLoc c1) $ HsCmdTop noExt c1
1410 arg2 = L (getLoc c2) $ HsCmdTop noExt c2
1411 return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]
1412
1413 checkCmd l e = cmdFail l e
1414
1415 checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
1416 checkCmdLStmt = locMap checkCmdStmt
1417
1418 checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
1419 checkCmdStmt _ (LastStmt x e s r) =
1420 checkCommand e >>= (\c -> return $ LastStmt x c s r)
1421 checkCmdStmt _ (BindStmt x pat e b f) =
1422 checkCommand e >>= (\c -> return $ BindStmt x pat c b f)
1423 checkCmdStmt _ (BodyStmt x e t g) =
1424 checkCommand e >>= (\c -> return $ BodyStmt x c t g)
1425 checkCmdStmt _ (LetStmt x bnds) = return $ LetStmt x bnds
1426 checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
1427 ss <- mapM checkCmdLStmt stmts
1428 return $ stmt { recS_ext = noExt, recS_stmts = ss }
1429 checkCmdStmt _ (XStmtLR _) = panic "checkCmdStmt"
1430 checkCmdStmt l stmt = cmdStmtFail l stmt
1431
1432 checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
1433 -> P (MatchGroup GhcPs (LHsCmd GhcPs))
1434 checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
1435 ms' <- mapM (locMap $ const convert) ms
1436 return $ mg { mg_ext = noExt, mg_alts = L l ms' }
1437 where convert match@(Match { m_grhss = grhss }) = do
1438 grhss' <- checkCmdGRHSs grhss
1439 return $ match { m_ext = noExt, m_grhss = grhss'}
1440 convert (XMatch _) = panic "checkCmdMatchGroup.XMatch"
1441 checkCmdMatchGroup (XMatchGroup {}) = panic "checkCmdMatchGroup"
1442
1443 checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
1444 checkCmdGRHSs (GRHSs x grhss binds) = do
1445 grhss' <- mapM checkCmdGRHS grhss
1446 return $ GRHSs x grhss' binds
1447 checkCmdGRHSs (XGRHSs _) = panic "checkCmdGRHSs"
1448
1449 checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
1450 checkCmdGRHS = locMap $ const convert
1451 where
1452 convert (GRHS x stmts e) = do
1453 c <- checkCommand e
1454 -- cmdStmts <- mapM checkCmdLStmt stmts
1455 return $ GRHS x {- cmdStmts -} stmts c
1456 convert (XGRHS _) = panic "checkCmdGRHS"
1457
1458
1459 cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
1460 cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
1461 cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a
1462 cmdStmtFail loc e = parseErrorSDoc loc
1463 (text "Parse error in command statement:" <+> ppr e)
1464
1465 ---------------------------------------------------------------------------
1466 -- Miscellaneous utilities
1467
1468 checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int))
1469 checkPrecP (L l (src,i))
1470 | 0 <= i && i <= maxPrecedence = return (L l (src,i))
1471 | otherwise
1472 = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
1473
1474 mkRecConstrOrUpdate
1475 :: LHsExpr GhcPs
1476 -> SrcSpan
1477 -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
1478 -> P (HsExpr GhcPs)
1479
1480 mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
1481 | isRdrDataCon c
1482 = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
1483 mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
1484 | dd = parseErrorSDoc l (text "You cannot use `..' in a record update")
1485 | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
1486
1487 mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
1488 mkRdrRecordUpd exp flds
1489 = RecordUpd { rupd_ext = noExt
1490 , rupd_expr = exp
1491 , rupd_flds = flds }
1492
1493 mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
1494 mkRdrRecordCon con flds
1495 = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds }
1496
1497 mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
1498 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
1499 mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
1500
1501 mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
1502 mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
1503 = HsRecField (L loc (Unambiguous noExt rdr)) arg pun
1504 mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _)
1505 = panic "mk_rec_upd_field"
1506
1507 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
1508 -> InlinePragma
1509 -- The (Maybe Activation) is because the user can omit
1510 -- the activation spec (and usually does)
1511 mkInlinePragma src (inl, match_info) mb_act
1512 = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes
1513 , inl_inline = inl
1514 , inl_sat = Nothing
1515 , inl_act = act
1516 , inl_rule = match_info }
1517 where
1518 act = case mb_act of
1519 Just act -> act
1520 Nothing -> -- No phase specified
1521 case inl of
1522 NoInline -> NeverActive
1523 _other -> AlwaysActive
1524
1525 -----------------------------------------------------------------------------
1526 -- utilities for foreign declarations
1527
1528 -- construct a foreign import declaration
1529 --
1530 mkImport :: Located CCallConv
1531 -> Located Safety
1532 -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
1533 -> P (HsDecl GhcPs)
1534 mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
1535 case cconv of
1536 L _ CCallConv -> mkCImport
1537 L _ CApiConv -> mkCImport
1538 L _ StdCallConv -> mkCImport
1539 L _ PrimCallConv -> mkOtherImport
1540 L _ JavaScriptCallConv -> mkOtherImport
1541 where
1542 -- Parse a C-like entity string of the following form:
1543 -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"
1544 -- If 'cid' is missing, the function name 'v' is used instead as symbol
1545 -- name (cf section 8.5.1 in Haskell 2010 report).
1546 mkCImport = do
1547 let e = unpackFS entity
1548 case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
1549 Nothing -> parseErrorSDoc loc (text "Malformed entity string")
1550 Just importSpec -> returnSpec importSpec
1551
1552 -- currently, all the other import conventions only support a symbol name in
1553 -- the entity string. If it is missing, we use the function name instead.
1554 mkOtherImport = returnSpec importSpec
1555 where
1556 entity' = if nullFS entity
1557 then mkExtName (unLoc v)
1558 else entity
1559 funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
1560 importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
1561
1562 returnSpec spec = return $ ForD noExt $ ForeignImport
1563 { fd_i_ext = noExt
1564 , fd_name = v
1565 , fd_sig_ty = ty
1566 , fd_fi = spec
1567 }
1568
1569
1570
1571 -- the string "foo" is ambiguous: either a header or a C identifier. The
1572 -- C identifier case comes first in the alternatives below, so we pick
1573 -- that one.
1574 parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
1575 -> Located SourceText
1576 -> Maybe ForeignImport
1577 parseCImport cconv safety nm str sourceText =
1578 listToMaybe $ map fst $ filter (null.snd) $
1579 readP_to_S parse str
1580 where
1581 parse = do
1582 skipSpaces
1583 r <- choice [
1584 string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
1585 string "wrapper" >> return (mk Nothing CWrapper),
1586 do optional (token "static" >> skipSpaces)
1587 ((mk Nothing <$> cimp nm) +++
1588 (do h <- munch1 hdr_char
1589 skipSpaces
1590 mk (Just (Header (SourceText h) (mkFastString h)))
1591 <$> cimp nm))
1592 ]
1593 skipSpaces
1594 return r
1595
1596 token str = do _ <- string str
1597 toks <- look
1598 case toks of
1599 c : _
1600 | id_char c -> pfail
1601 _ -> return ()
1602
1603 mk h n = CImport cconv safety h n sourceText
1604
1605 hdr_char c = not (isSpace c) -- header files are filenames, which can contain
1606 -- pretty much any char (depending on the platform),
1607 -- so just accept any non-space character
1608 id_first_char c = isAlpha c || c == '_'
1609 id_char c = isAlphaNum c || c == '_'
1610
1611 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1612 +++ (do isFun <- case cconv of
1613 L _ CApiConv ->
1614 option True
1615 (do token "value"
1616 skipSpaces
1617 return False)
1618 _ -> return True
1619 cid' <- cid
1620 return (CFunction (StaticTarget NoSourceText cid'
1621 Nothing isFun)))
1622 where
1623 cid = return nm +++
1624 (do c <- satisfy id_first_char
1625 cs <- many (satisfy id_char)
1626 return (mkFastString (c:cs)))
1627
1628
1629 -- construct a foreign export declaration
1630 --
1631 mkExport :: Located CCallConv
1632 -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
1633 -> P (HsDecl GhcPs)
1634 mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
1635 = return $ ForD noExt $
1636 ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty
1637 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
1638 (L le esrc) }
1639 where
1640 entity' | nullFS entity = mkExtName (unLoc v)
1641 | otherwise = entity
1642
1643 -- Supplying the ext_name in a foreign decl is optional; if it
1644 -- isn't there, the Haskell name is assumed. Note that no transformation
1645 -- of the Haskell name is then performed, so if you foreign export (++),
1646 -- it's external name will be "++". Too bad; it's important because we don't
1647 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1648 --
1649 mkExtName :: RdrName -> CLabelString
1650 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1651
1652 --------------------------------------------------------------------------------
1653 -- Help with module system imports/exports
1654
1655 data ImpExpSubSpec = ImpExpAbs
1656 | ImpExpAll
1657 | ImpExpList [Located ImpExpQcSpec]
1658 | ImpExpAllWith [Located ImpExpQcSpec]
1659
1660 data ImpExpQcSpec = ImpExpQcName (Located RdrName)
1661 | ImpExpQcType (Located RdrName)
1662 | ImpExpQcWildcard
1663
1664 mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
1665 mkModuleImpExp (L l specname) subs =
1666 case subs of
1667 ImpExpAbs
1668 | isVarNameSpace (rdrNameSpace name)
1669 -> return $ IEVar noExt (L l (ieNameFromSpec specname))
1670 | otherwise -> IEThingAbs noExt . L l <$> nameT
1671 ImpExpAll -> IEThingAll noExt . L l <$> nameT
1672 ImpExpList xs ->
1673 (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) [])
1674 <$> nameT
1675 ImpExpAllWith xs ->
1676 do allowed <- extension patternSynonymsEnabled
1677 if allowed
1678 then
1679 let withs = map unLoc xs
1680 pos = maybe NoIEWildcard IEWildcard
1681 (findIndex isImpExpQcWildcard withs)
1682 ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
1683 in (\newName
1684 -> IEThingWith noExt (L l newName) pos ies []) <$> nameT
1685 else parseErrorSDoc l
1686 (text "Illegal export form (use PatternSynonyms to enable)")
1687 where
1688 name = ieNameVal specname
1689 nameT =
1690 if isVarNameSpace (rdrNameSpace name)
1691 then parseErrorSDoc l
1692 (text "Expecting a type constructor but found a variable,"
1693 <+> quotes (ppr name) <> text "."
1694 $$ if isSymOcc $ rdrNameOcc name
1695 then text "If" <+> quotes (ppr name) <+> text "is a type constructor"
1696 <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
1697 else empty)
1698 else return $ ieNameFromSpec specname
1699
1700 ieNameVal (ImpExpQcName ln) = unLoc ln
1701 ieNameVal (ImpExpQcType ln) = unLoc ln
1702 ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard"
1703
1704 ieNameFromSpec (ImpExpQcName ln) = IEName ln
1705 ieNameFromSpec (ImpExpQcType ln) = IEType ln
1706 ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
1707
1708 wrapped = map (\(L l x) -> L l (ieNameFromSpec x))
1709
1710 mkTypeImpExp :: Located RdrName -- TcCls or Var name space
1711 -> P (Located RdrName)
1712 mkTypeImpExp name =
1713 do allowed <- extension explicitNamespacesEnabled
1714 if allowed
1715 then return (fmap (`setRdrNameSpace` tcClsName) name)
1716 else parseErrorSDoc (getLoc name)
1717 (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
1718
1719 checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
1720 checkImportSpec ie@(L _ specs) =
1721 case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
1722 [] -> return ie
1723 (l:_) -> importSpecError l
1724 where
1725 importSpecError l =
1726 parseErrorSDoc l
1727 (text "Illegal import form, this syntax can only be used to bundle"
1728 $+$ text "pattern synonyms with types in module exports.")
1729
1730 -- In the correct order
1731 mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
1732 mkImpExpSubSpec [] = return ([], ImpExpList [])
1733 mkImpExpSubSpec [L _ ImpExpQcWildcard] =
1734 return ([], ImpExpAll)
1735 mkImpExpSubSpec xs =
1736 if (any (isImpExpQcWildcard . unLoc) xs)
1737 then return $ ([], ImpExpAllWith xs)
1738 else return $ ([], ImpExpList xs)
1739
1740 isImpExpQcWildcard :: ImpExpQcSpec -> Bool
1741 isImpExpQcWildcard ImpExpQcWildcard = True
1742 isImpExpQcWildcard _ = False
1743
1744 -----------------------------------------------------------------------------
1745 -- Warnings and failures
1746
1747 warnStarIsType :: SrcSpan -> P ()
1748 warnStarIsType span = addWarning Opt_WarnStarIsType span msg
1749 where
1750 msg = text "Using" <+> quotes (text "*")
1751 <+> text "(or its Unicode variant) to mean"
1752 <+> quotes (text "Data.Kind.Type")
1753 $$ text "relies on the StarIsType extension."
1754 $$ text "Suggested fix: use" <+> quotes (text "Type")
1755 <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
1756
1757 warnStarBndr :: SrcSpan -> P ()
1758 warnStarBndr span = addWarning Opt_WarnStarBinder span msg
1759 where
1760 msg = text "Desugaring" <+> quotes (text "*") <+> text "in a binder"
1761 <+> text "position as a type operator despite StarIsType."
1762 $$ text "NB. To use (or export) this operator in"
1763 <+> text "modules with StarIsType,"
1764 $$ text " including the definition module, you must qualify it."
1765
1766 failOpFewArgs :: Located RdrName -> P a
1767 failOpFewArgs (L loc op) =
1768 do { star_is_type <- extension starIsTypeEnabled
1769 ; let msg = too_few $$ starInfo star_is_type op
1770 ; parseErrorSDoc loc msg }
1771 where
1772 too_few = text "Operator applied to too few arguments:" <+> ppr op
1773
1774 -----------------------------------------------------------------------------
1775 -- Misc utils
1776
1777 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1778 parseErrorSDoc span s = failSpanMsgP span s
1779
1780 -- | Hint about bang patterns, assuming @BangPatterns@ is off.
1781 hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
1782 hintBangPat span e = do
1783 bang_on <- extension bangPatEnabled
1784 unless bang_on $
1785 parseErrorSDoc span
1786 (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
1787
1788 data SumOrTuple
1789 = Sum ConTag Arity (LHsExpr GhcPs)
1790 | Tuple [LHsTupArg GhcPs]
1791
1792 mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)
1793
1794 -- Tuple
1795 mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
1796
1797 -- Sum
1798 mkSumOrTuple Unboxed _ (Sum alt arity e) =
1799 return (ExplicitSum noExt alt arity e)
1800 mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
1801 parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
1802 where
1803 ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc
1804 ppr_boxed_sum alt arity e =
1805 text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"
1806
1807 ppr_bars n = hsep (replicate n (Outputable.char '|'))
1808
1809 mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
1810 mkLHsOpTy x op y =
1811 let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
1812 in L loc (mkHsOpTy x op y)