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