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