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