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