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