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