b86068cf0f314f453e5292a2e024fa3d36d6f8ac
[ghc.git] / compiler / parser / RdrHsSyn.lhs
1 %
2 % (c) The University of Glasgow, 1996-2003
3
4 Functions over HsSyn specialised to RdrName.
5
6 \begin{code}
7 module RdrHsSyn (
8         extractHsTyRdrTyVars, 
9         extractHsRhoRdrTyVars, extractGenericPatTyVars,
10  
11         mkHsOpApp, 
12         mkHsIntegral, mkHsFractional, mkHsIsString,
13         mkHsDo, mkHsSplice, mkTopSpliceDecl,
14         mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
15         splitCon, mkInlinePragma,       
16         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
17
18         cvBindGroup,
19         cvBindsAndSigs,
20         cvTopDecls,
21         findSplice, checkDecBrGroup,
22         placeHolderPunRhs,
23
24         -- Stuff to do with Foreign declarations
25         mkImport,
26         parseCImport,
27         mkExport,
28         mkExtName,           -- RdrName -> CLabelString
29         mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
30         mkSimpleConDecl, 
31         mkDeprecatedGadtRecordDecl,
32
33         -- Bunch of functions in the parser monad for 
34         -- checking and constructing values
35         checkPrecP,           -- Int -> P Int
36         checkContext,         -- HsType -> P HsContext
37         checkPred,            -- HsType -> P HsPred
38         checkTyVars,          -- [LHsType RdrName] -> P ()
39         checkKindSigs,        -- [LTyClDecl RdrName] -> P ()
40         checkInstType,        -- HsType -> P HsType
41         checkPattern,         -- HsExp -> P HsPat
42         bang_RDR,
43         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
44         checkDo,              -- [Stmt] -> P [Stmt]
45         checkMDo,             -- [Stmt] -> P [Stmt]
46         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
47         checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
48         parseError,         
49         parseErrorSDoc,     
50     ) where
51
52 import HsSyn            -- Lots of it
53 import Class            ( FunDep )
54 import TypeRep          ( Kind )
55 import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
56                           isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
57 import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
58                           InlinePragma(..) )
59 import Lexer
60 import TysWiredIn       ( unitTyCon ) 
61 import ForeignCall
62 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc, 
63                           occNameString )
64 import PrelNames        ( forall_tv_RDR )
65 import DynFlags
66 import SrcLoc
67 import OrdList          ( OrdList, fromOL )
68 import Bag              ( Bag, emptyBag, snocBag, consBag, foldrBag )
69 import Outputable
70 import FastString
71 import Maybes
72
73 import Control.Applicative ((<$>))       
74 import Text.ParserCombinators.ReadP as ReadP
75 import Data.List        ( nubBy )
76 import Data.Char
77
78 #include "HsVersions.h"
79 \end{code}
80
81
82 %************************************************************************
83 %*                                                                      *
84 \subsection{A few functions over HsSyn at RdrName}
85 %*                                                                    *
86 %************************************************************************
87
88 extractHsTyRdrNames finds the free variables of a HsType
89 It's used when making the for-alls explicit.
90
91 \begin{code}
92 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
93 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
94
95 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
96 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
97
98 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
99 -- This one takes the context and tau-part of a 
100 -- sigma type and returns their free type variables
101 extractHsRhoRdrTyVars ctxt ty 
102  = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
103
104 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
105 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
106
107 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
108 extract_pred (HsClassP _   tys) acc = extract_ltys tys acc
109 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
110 extract_pred (HsIParam _   ty ) acc = extract_lty ty acc
111
112 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
113 extract_ltys tys acc = foldr extract_lty acc tys
114
115 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
116 extract_lty (L loc ty) acc 
117   = case ty of
118       HsTyVar tv                -> extract_tv loc tv acc
119       HsBangTy _ ty             -> extract_lty ty acc
120       HsRecTy flds              -> foldr (extract_lty . cd_fld_type) acc flds
121       HsAppTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
122       HsListTy ty               -> extract_lty ty acc
123       HsPArrTy ty               -> extract_lty ty acc
124       HsTupleTy _ tys           -> extract_ltys tys acc
125       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
126       HsPredTy p                -> extract_pred p acc
127       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
128       HsParTy ty                -> extract_lty ty acc
129       HsNumTy _                 -> acc
130       HsSpliceTy {}             -> acc  -- Type splices mention no type variables
131       HsSpliceTyOut {}          -> acc  -- Type splices mention no type variables
132       HsKindSig ty _            -> extract_lty ty acc
133       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
134       HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
135                                            extract_lctxt cx (extract_lty ty []))
136                                 where
137                                    locals = hsLTyVarNames tvs
138       HsDocTy ty _              -> extract_lty ty acc
139
140 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
141 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
142                       | otherwise     = acc
143
144 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
145 -- Get the type variables out of the type patterns in a bunch of
146 -- possibly-generic bindings in a class declaration
147 extractGenericPatTyVars binds
148   = nubBy eqLocated (foldrBag get [] binds)
149   where
150     get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
151     get _                                                 acc = acc
152
153     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
154     get_m _                                        acc = acc
155 \end{code}
156
157
158 %************************************************************************
159 %*                                                                      *
160 \subsection{Construction functions for Rdr stuff}
161 %*                                                                    *
162 %************************************************************************
163
164 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
165 by deriving them from the name of the class.  We fill in the names for the
166 tycon and datacon corresponding to the class, by deriving them from the
167 name of the class itself.  This saves recording the names in the interface
168 file (which would be equally good).
169
170 Similarly for mkConDecl, mkClassOpSig and default-method names.
171
172         *** See "THE NAMING STORY" in HsDecls ****
173   
174 \begin{code}
175 mkClassDecl :: SrcSpan
176             -> Located (LHsContext RdrName, LHsType RdrName) 
177             -> Located [Located (FunDep RdrName)]
178             -> Located (OrdList (LHsDecl RdrName))
179             -> P (LTyClDecl RdrName)
180
181 mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
182   = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
183        ; (cls, tparams) <- checkTyClHdr tycl_hdr
184        ; tyvars <- checkTyVars tparams      -- Only type vars allowed
185        ; checkKindSigs ats
186        ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
187                                     tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
188                                     tcdATs   = ats, tcdDocs  = docs })) }
189
190 mkTyData :: SrcSpan
191          -> NewOrData
192          -> Bool                -- True <=> data family instance
193          -> Located (LHsContext RdrName, LHsType RdrName)
194          -> Maybe Kind
195          -> [LConDecl RdrName]
196          -> Maybe [LHsType RdrName]
197          -> P (LTyClDecl RdrName)
198 mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
199   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
200
201        ; (tyvars, typats) <- checkTParams is_family tparams
202        ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
203                                  tcdTyVars = tyvars, tcdTyPats = typats, 
204                                  tcdCons = data_cons, 
205                                  tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
206
207 mkTySynonym :: SrcSpan 
208             -> Bool             -- True <=> type family instances
209             -> LHsType RdrName  -- LHS
210             -> LHsType RdrName  -- RHS
211             -> P (LTyClDecl RdrName)
212 mkTySynonym loc is_family lhs rhs
213   = do { (tc, tparams) <- checkTyClHdr lhs
214        ; (tyvars, typats) <- checkTParams is_family tparams
215        ; return (L loc (TySynonym tc tyvars typats rhs)) }
216
217 mkTyFamily :: SrcSpan
218            -> FamilyFlavour
219            -> LHsType RdrName   -- LHS
220            -> Maybe Kind        -- Optional kind signature
221            -> P (LTyClDecl RdrName)
222 mkTyFamily loc flavour lhs ksig
223   = do { (tc, tparams) <- checkTyClHdr lhs
224        ; tyvars <- checkTyVars tparams
225        ; return (L loc (TyFamily flavour tc tyvars ksig)) }
226
227 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
228 -- If the user wrote
229 --      $(e)
230 -- then that's the splice, but if she wrote, say,
231 --      f x
232 -- then behave as if she'd written
233 --      $(f x)
234 mkTopSpliceDecl expr
235   = SpliceD (SpliceDecl expr')
236   where
237     expr' = case expr of
238               (L _ (HsSpliceE (HsSplice _ expr))) -> expr
239               _other                              -> expr
240 \end{code}
241
242 %************************************************************************
243 %*                                                                      *
244 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
245 %*                                                                      *
246 %************************************************************************
247
248 Function definitions are restructured here. Each is assumed to be recursive
249 initially, and non recursive definitions are discovered by the dependency
250 analyser.
251
252
253 \begin{code}
254 --  | Groups together bindings for a single function
255 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
256 cvTopDecls decls = go (fromOL decls)
257   where
258     go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
259     go []                   = []
260     go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
261                             where (L l' b', ds') = getMonoBind (L l b) ds
262     go (d : ds)             = d : go ds
263
264 -- Declaration list may only contain value bindings and signatures.
265 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
266 cvBindGroup binding
267   = case cvBindsAndSigs binding of
268       (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
269                                  ValBindsIn mbs sigs
270
271 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
272   -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
273 -- Input decls contain just value bindings and signatures
274 -- and in case of class or instance declarations also
275 -- associated type declarations. They might also contain Haddock comments.
276 cvBindsAndSigs  fb = go (fromOL fb)
277   where
278     go []                  = (emptyBag, [], [], [])
279     go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
280                            where (bs, ss, ts, docs) = go ds
281     go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
282                            where (b', ds')    = getMonoBind (L l b) ds
283                                  (bs, ss, ts, docs) = go ds'
284     go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
285                            where (bs, ss, ts, docs) = go ds
286     go (L l (DocD d) : ds) =  (bs, ss, ts, (L l d) : docs)
287                            where (bs, ss, ts, docs) = go ds
288     go (L _ d : _)        = pprPanic "cvBindsAndSigs" (ppr d)
289
290 -----------------------------------------------------------------------------
291 -- Group function bindings into equation groups
292
293 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
294   -> (LHsBind RdrName, [LHsDecl RdrName])
295 -- Suppose      (b',ds') = getMonoBind b ds
296 --      ds is a list of parsed bindings
297 --      b is a MonoBinds that has just been read off the front
298
299 -- Then b' is the result of grouping more equations from ds that
300 -- belong with b into a single MonoBinds, and ds' is the depleted
301 -- list of parsed bindings.
302 --
303 -- All Haddock comments between equations inside the group are 
304 -- discarded.
305 --
306 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
307
308 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
309                                fun_matches = MatchGroup mtchs1 _ })) binds
310   | has_args mtchs1
311   = go is_infix1 mtchs1 loc1 binds []
312   where
313     go is_infix mtchs loc 
314        (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
315                                 fun_matches = MatchGroup mtchs2 _ })) : binds) _
316         | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) 
317                         (combineSrcSpans loc loc2) binds []
318     go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls 
319         = let doc_decls' = doc_decl : doc_decls  
320           in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
321     go is_infix mtchs loc binds doc_decls
322         = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
323         -- Reverse the final matches, to get it back in the right order
324         -- Do the same thing with the trailing doc comments
325
326 getMonoBind bind binds = (bind, binds)
327
328 has_args :: [LMatch RdrName] -> Bool
329 has_args []                           = panic "RdrHsSyn:has_args"
330 has_args ((L _ (Match args _ _)) : _) = not (null args)
331         -- Don't group together FunBinds if they have
332         -- no arguments.  This is necessary now that variable bindings
333         -- with no arguments are now treated as FunBinds rather
334         -- than pattern bindings (tests/rename/should_fail/rnfail002).
335 \end{code}
336
337 \begin{code}
338 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
339 findSplice ds = addl emptyRdrGroup ds
340
341 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
342 -- Turn the body of a [d| ... |] into a HsGroup
343 -- There should be no splices in the "..."
344 checkDecBrGroup decls 
345   = case addl emptyRdrGroup decls of
346         (group, Nothing) -> return group
347         (_, Just (SpliceDecl (L loc _), _)) -> 
348                 parseError loc "Declaration splices are not permitted inside declaration brackets"
349                 -- Why not?  See Section 7.3 of the TH paper.  
350
351 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
352         -- This stuff reverses the declarations (again) but it doesn't matter
353
354 -- Base cases
355 addl gp []           = (gp, Nothing)
356 addl gp (L l d : ds) = add gp l d ds
357
358
359 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
360   -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
361
362 add gp _ (SpliceD e) ds = (gp, Just (e, ds))
363
364 -- Class declarations: pull out the fixity signatures to the top
365 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) 
366     l (TyClD d) ds
367         | isClassDecl d =       
368                 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
369                 addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
370         | otherwise =
371                 addl (gp { hs_tyclds = L l d : ts }) ds
372
373 -- Signatures: fixity sigs go a different place than all others
374 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
375   = addl (gp {hs_fixds = L l f : ts}) ds
376 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
377   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
378
379 -- Value declarations: use add_bind
380 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
381   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
382
383 -- The rest are routine
384 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
385   = addl (gp { hs_instds = L l d : ts }) ds
386 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
387   = addl (gp { hs_derivds = L l d : ts }) ds
388 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
389   = addl (gp { hs_defds = L l d : ts }) ds
390 add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
391   = addl (gp { hs_fords = L l d : ts }) ds
392 add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
393   = addl (gp { hs_warnds = L l d : ts }) ds
394 add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
395   = addl (gp { hs_annds = L l d : ts }) ds
396 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
397   = addl (gp { hs_ruleds = L l d : ts }) ds
398
399 add gp l (DocD d) ds
400   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
401
402 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
403 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
404 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
405
406 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
407 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
408 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
409 \end{code}
410
411 %************************************************************************
412 %*                                                                      *
413 \subsection[PrefixToHS-utils]{Utilities for conversion}
414 %*                                                                      *
415 %************************************************************************
416
417
418 \begin{code}
419 -----------------------------------------------------------------------------
420 -- splitCon
421
422 -- When parsing data declarations, we sometimes inadvertently parse
423 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
424 -- This function splits up the type application, adds any pending
425 -- arguments, and converts the type constructor back into a data constructor.
426
427 splitCon :: LHsType RdrName
428       -> P (Located RdrName, HsConDeclDetails RdrName)
429 -- This gets given a "type" that should look like
430 --      C Int Bool
431 -- or   C { x::Int, y::Bool }
432 -- and returns the pieces
433 splitCon ty
434  = split ty []
435  where
436    split (L _ (HsAppTy t u)) ts = split t (u : ts)
437    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
438                                      return (data_con, mk_rest ts)
439    split (L l _) _              = parseError l "parse error in data/newtype declaration"
440
441    mk_rest [L _ (HsRecTy flds)] = RecCon flds
442    mk_rest ts                   = PrefixCon ts
443
444 mkDeprecatedGadtRecordDecl :: SrcSpan 
445                            -> Located RdrName
446                            -> [ConDeclField RdrName]
447                            -> LHsType RdrName
448                            ->  P (LConDecl  RdrName)
449 -- This one uses the deprecated syntax
450 --    C { x,y ::Int } :: T a b
451 -- We give it a RecCon details right away
452 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
453   = do { data_con <- tyConToDataCon con_loc con
454        ; return (L loc (ConDecl { con_old_rec  = True
455                                 , con_name     = data_con
456                                 , con_explicit = Implicit
457                                 , con_qvars    = []
458                                 , con_cxt      = noLoc []
459                                 , con_details  = RecCon flds
460                                 , con_res      = ResTyGADT res_ty
461                                 , con_doc      = Nothing })) }
462
463 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
464                 -> LHsContext RdrName -> HsConDeclDetails RdrName
465                 -> ConDecl RdrName
466
467 mkSimpleConDecl name qvars cxt details
468   = ConDecl { con_old_rec  = False
469             , con_name     = name
470             , con_explicit = Explicit
471             , con_qvars    = qvars
472             , con_cxt      = cxt
473             , con_details  = details
474             , con_res      = ResTyH98
475             , con_doc      = Nothing }
476
477 mkGadtDecl :: [Located RdrName]
478            -> LHsType RdrName     -- Always a HsForAllTy
479            -> [ConDecl RdrName]
480 -- We allow C,D :: ty
481 -- and expand it as if it had been 
482 --    C :: ty; D :: ty
483 -- (Just like type signatures in general.)
484 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
485   = [mk_gadt_con name | name <- names]
486   where
487     (details, res_ty)           -- See Note [Sorting out the result type]
488       = case tau of
489           L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds,  res_ty)
490           _other                                    -> (PrefixCon [], tau)
491
492     mk_gadt_con name
493        = ConDecl { con_old_rec  = False
494                  , con_name     = name
495                  , con_explicit = imp
496                  , con_qvars    = qvars
497                  , con_cxt      = cxt
498                  , con_details  = details
499                  , con_res      = ResTyGADT res_ty
500                  , con_doc      = Nothing }
501 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
502
503 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
504 tyConToDataCon loc tc
505   | isTcOcc (rdrNameOcc tc)
506   = return (L loc (setRdrNameSpace tc srcDataName))
507   | otherwise
508   = parseErrorSDoc loc (msg $$ extra)
509   where
510     msg = text "Not a data constructor:" <+> quotes (ppr tc)
511     extra | tc == forall_tv_RDR
512           = text "Perhaps you intended to use -XExistentialQuantification"
513           | otherwise = empty
514 \end{code}
515
516 Note [Sorting out the result type]
517 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
518 In a GADT declaration which is not a record, we put the whole constr
519 type into the ResTyGADT for now; the renamer will unravel it once it
520 has sorted out operator fixities. Consider for example
521      C :: a :*: b -> a :*: b -> a :+: b
522 Initially this type will parse as
523       a :*: (b -> (a :*: (b -> (a :+: b))))
524
525 so it's hard to split up the arguments until we've done the precedence
526 resolution (in the renamer) On the other hand, for a record
527         { x,y :: Int } -> a :*: b
528 there is no doubt.  AND we need to sort records out so that
529 we can bring x,y into scope.  So:
530    * For PrefixCon we keep all the args in the ResTyGADT
531    * For RecCon we do not
532
533 \begin{code}
534 ----------------------------------------------------------------------------
535 -- Various Syntactic Checks
536
537 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
538 checkInstType (L l t)
539   = case t of
540         HsForAllTy exp tvs ctxt ty -> do
541                 dict_ty <- checkDictTy ty
542                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
543
544         HsParTy ty -> checkInstType ty
545
546         ty ->   do dict_ty <- checkDictTy (L l ty)
547                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
548
549 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
550 checkDictTy (L spn ty) = check ty []
551   where
552   check (HsTyVar tc)            args | isRdrTc tc = done tc args
553   check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
554   check (HsAppTy l r) args = check (unLoc l) (r:args)
555   check (HsParTy t)   args = check (unLoc t) args
556   check _ _ = parseError spn "Malformed instance header"
557
558   done tc args = return (L spn (HsPredTy (HsClassP tc args)))
559
560 checkTParams :: Bool      -- Type/data family
561              -> [LHsType RdrName]
562              -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
563 -- checkTParams checks the type parameters of a data/newtype declaration
564 -- There are two cases:
565 --
566 --  a) Vanilla data/newtype decl. In that case 
567 --        - the type parameters should all be type variables
568 --        - they may have a kind annotation
569 --
570 --  b) Family data/newtype decl.  In that case
571 --        - The type parameters may be arbitrary types
572 --        - We find the type-varaible binders by find the 
573 --          free type vars of those types
574 --        - We make them all kind-sig-free binders (UserTyVar)
575 --          If there are kind sigs in the type parameters, they
576 --          will fix the binder's kind when we kind-check the 
577 --          type parameters
578 checkTParams is_family tparams
579   | not is_family        -- Vanilla case (a)
580   = do { tyvars <- checkTyVars tparams
581        ; return (tyvars, Nothing) }
582   | otherwise            -- Family case (b)
583   = do { let tyvars = [L l (UserTyVar tv) 
584                       | L l tv <- extractHsTysRdrTyVars tparams]
585        ; return (tyvars, Just tparams) }
586
587 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
588 -- Check whether the given list of type parameters are all type variables
589 -- (possibly with a kind signature).  If the second argument is `False',
590 -- only type variables are allowed and we raise an error on encountering a
591 -- non-variable; otherwise, we allow non-variable arguments and return the
592 -- entire list of parameters.
593 checkTyVars tparms = mapM chk tparms
594   where
595         -- Check that the name space is correct!
596     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
597         | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
598     chk (L l (HsTyVar tv))
599         | isRdrTyVar tv    = return (L l (UserTyVar tv))
600     chk (L l _)            =
601           parseError l "Type found where type variable expected"
602
603 checkTyClHdr :: LHsType RdrName
604              -> P (Located RdrName,          -- the head symbol (type or class name)
605                    [LHsType RdrName])        -- parameters of head symbol
606 -- Well-formedness check and decomposition of type and class heads.
607 -- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
608 --              Int :*: Bool   into    (:*:, [Int, Bool])
609 -- returning the pieces
610 checkTyClHdr ty
611   = goL ty []
612   where
613     goL (L l ty) acc = go l ty acc
614
615     go l (HsTyVar tc) acc 
616         | isRdrTc tc         = return (L l tc, acc)
617                                      
618     go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
619         | isRdrTc tc         = return (ltc, t1:t2:acc)
620     go _ (HsParTy ty)    acc = goL ty acc
621     go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
622     go l _               _   = parseError l "Malformed head of type or class declaration"
623
624 -- Check that associated type declarations of a class are all kind signatures.
625 --
626 checkKindSigs :: [LTyClDecl RdrName] -> P ()
627 checkKindSigs = mapM_ check
628   where
629     check (L l tydecl) 
630       | isFamilyDecl tydecl
631         || isSynDecl tydecl  = return ()
632       | otherwise            = 
633         parseError l "Type declaration in a class must be a kind signature or synonym default"
634
635 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
636 checkContext (L l t)
637   = check t
638  where
639   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
640     = do ctx <- mapM checkPred ts
641          return (L l ctx)
642
643   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
644     = check (unLoc ty)
645
646   check (HsTyVar t)     -- Empty context shows up as a unit type ()
647     | t == getRdrName unitTyCon = return (L l [])
648
649   check t 
650     = do p <- checkPred (L l t)
651          return (L l [p])
652
653
654 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
655 -- Watch out.. in ...deriving( Show )... we use checkPred on 
656 -- the list of partially applied predicates in the deriving,
657 -- so there can be zero args.
658 checkPred (L spn (HsPredTy (HsIParam n ty)))
659   = return (L spn (HsIParam n ty))
660 checkPred (L spn ty)
661   = check spn ty []
662   where
663     checkl (L l ty) args = check l ty args
664
665     check _loc (HsPredTy pred@(HsEqualP _ _)) 
666                                        args | null args
667                                             = return $ L spn pred
668     check _loc (HsTyVar t)             args | not (isRdrTyVar t) 
669                                             = return (L spn (HsClassP t args))
670     check _loc (HsAppTy l r)           args = checkl l (r:args)
671     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
672     check _loc (HsParTy t)             args = checkl t args
673     check loc _                        _    = parseError loc  
674                                                 "malformed class assertion"
675
676 ---------------------------------------------------------------------------
677 -- Checking statements in a do-expression
678 --      We parse   do { e1 ; e2 ; }
679 --      as [ExprStmt e1, ExprStmt e2]
680 -- checkDo (a) checks that the last thing is an ExprStmt
681 --         (b) returns it separately
682 -- same comments apply for mdo as well
683
684 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
685
686 checkDo  = checkDoMDo "a " "'do'"
687 checkMDo = checkDoMDo "an " "'mdo'"
688
689 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
690 checkDoMDo _   nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
691 checkDoMDo pre nm _   ss   = do
692   check ss
693   where 
694         check  []                     = panic "RdrHsSyn:checkDoMDo"
695         check  [L _ (ExprStmt e _ _)] = return ([], e)
696         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
697                                          " construct must be an expression")
698         check (s:ss) = do
699           (ss',e') <-  check ss
700           return ((s:ss'),e')
701
702 -- -------------------------------------------------------------------------
703 -- Checking Patterns.
704
705 -- We parse patterns as expressions and check for valid patterns below,
706 -- converting the expression into a pattern at the same time.
707
708 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
709 checkPattern e = checkLPat e
710
711 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
712 checkPatterns es = mapM checkPattern es
713
714 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
715 checkLPat e@(L l _) = checkPat l e []
716
717 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
718 checkPat loc (L l (HsVar c)) args
719   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
720 checkPat loc e args     -- OK to let this happen even if bang-patterns
721                         -- are not enabled, because there is no valid
722                         -- non-bang-pattern parse of (C ! e)
723   | Just (e', args') <- splitBang e
724   = do  { args'' <- checkPatterns args'
725         ; checkPat loc e' (args'' ++ args) }
726 checkPat loc (L _ (HsApp f x)) args
727   = do { x <- checkLPat x; checkPat loc f (x:args) }
728 checkPat loc (L _ e) []
729   = do { pState <- getPState
730        ; p <- checkAPat (dflags pState) loc e
731        ; return (L loc p) }
732 checkPat loc _ _
733   = patFail loc
734
735 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
736 checkAPat dynflags loc e = case e of
737    EWildPat -> return (WildPat placeHolderType)
738    HsVar x  -> return (VarPat x)
739    HsLit l  -> return (LitPat l)
740
741    -- Overloaded numeric patterns (e.g. f 0 x = x)
742    -- Negation is recorded separately, so that the literal is zero or +ve
743    -- NB. Negative *primitive* literals are already handled by the lexer
744    HsOverLit pos_lit          -> return (mkNPat pos_lit Nothing)
745    NegApp (L _ (HsOverLit pos_lit)) _ 
746                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
747    
748    SectionR (L _ (HsVar bang)) e        -- (! x)
749         | bang == bang_RDR 
750         -> do { bang_on <- extension bangPatEnabled
751               ; if bang_on then checkLPat e >>= (return . BangPat)
752                 else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
753
754    ELazyPat e         -> checkLPat e >>= (return . LazyPat)
755    EAsPat n e         -> checkLPat e >>= (return . AsPat n)
756    -- view pattern is well-formed if the pattern is
757    EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
758    ExprWithTySig e t  -> do e <- checkLPat e
759                             -- Pattern signatures are parsed as sigtypes,
760                             -- but they aren't explicit forall points.  Hence
761                             -- we have to remove the implicit forall here.
762                             let t' = case t of 
763                                        L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
764                                        other -> other
765                             return (SigPatIn e t')
766    
767    -- n+k patterns
768    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ 
769          (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
770                       | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
771                       -> return (mkNPlusKPat (L nloc n) lit)
772    
773    OpApp l op _fix r  -> do l <- checkLPat l
774                             r <- checkLPat r
775                             case op of
776                                L cl (HsVar c) | isDataOcc (rdrNameOcc c)
777                                       -> return (ConPatIn (L cl c) (InfixCon l r))
778                                _ -> patFail loc
779    
780    HsPar e            -> checkLPat e >>= (return . ParPat)
781    ExplicitList _ es  -> do ps <- mapM checkLPat es
782                             return (ListPat ps placeHolderType)
783    ExplicitPArr _ es  -> do ps <- mapM checkLPat es
784                             return (PArrPat ps placeHolderType)
785    
786    ExplicitTuple es b 
787      | all tupArgPresent es  -> do ps <- mapM checkLPat [e | Present e <- es]
788                                    return (TuplePat ps b placeHolderType)
789      | otherwise -> parseError loc "Illegal tuple section in pattern"
790    
791    RecordCon c _ (HsRecFields fs dd)
792                       -> do fs <- mapM checkPatField fs
793                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
794    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
795 -- Generics 
796    HsType ty          -> return (TypePat ty) 
797    _                  -> patFail loc
798
799 placeHolderPunRhs :: HsExpr RdrName
800 -- The RHS of a punned record field will be filled in by the renamer
801 -- It's better not to make it an error, in case we want to print it when debugging
802 placeHolderPunRhs = HsVar pun_RDR
803
804 plus_RDR, bang_RDR, pun_RDR :: RdrName
805 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
806 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
807 pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
808
809 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
810 checkPatField fld = do  { p <- checkLPat (hsRecFieldArg fld)
811                         ; return (fld { hsRecFieldArg = p }) }
812
813 patFail :: SrcSpan -> P a
814 patFail loc = parseError loc "Parse error in pattern"
815
816
817 ---------------------------------------------------------------------------
818 -- Check Equation Syntax
819
820 checkValDef :: LHsExpr RdrName
821             -> Maybe (LHsType RdrName)
822             -> Located (GRHSs RdrName)
823             -> P (HsBind RdrName)
824
825 checkValDef lhs (Just sig) grhss
826         -- x :: ty = rhs  parses as a *pattern* binding
827   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
828
829 checkValDef lhs opt_sig grhss
830   = do  { mb_fun <- isFunLhs lhs
831         ; case mb_fun of
832             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
833                                                 fun is_infix pats opt_sig grhss
834             Nothing -> checkPatBind lhs grhss }
835
836 checkFunBind :: SrcSpan
837              -> Located RdrName
838              -> Bool
839              -> [LHsExpr RdrName]
840              -> Maybe (LHsType RdrName)
841              -> Located (GRHSs RdrName)
842              -> P (HsBind RdrName)
843 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
844   = do  ps <- checkPatterns pats
845         let match_span = combineSrcSpans lhs_loc rhs_span
846         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
847         -- The span of the match covers the entire equation.  
848         -- That isn't quite right, but it'll do for now.
849
850 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
851 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
852 makeFunBind fn is_infix ms 
853   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
854               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
855
856 checkPatBind :: LHsExpr RdrName
857              -> Located (GRHSs RdrName)
858              -> P (HsBind RdrName)
859 checkPatBind lhs (L _ grhss)
860   = do  { lhs <- checkPattern lhs
861         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
862
863 checkValSig
864         :: LHsExpr RdrName
865         -> LHsType RdrName
866         -> P (Sig RdrName)
867 checkValSig (L l (HsVar v)) ty 
868   | isUnqual v && not (isDataOcc (rdrNameOcc v))
869   = return (TypeSig (L l v) ty)
870 checkValSig lhs@(L l _)         _
871   | looks_like_foreign lhs
872   = parseError l "Invalid type signature; perhaps you meant to use -XForeignFunctionInterface?"
873   | otherwise
874   = parseError l "Invalid type signature: should be of form <variable> :: <type>"
875   where
876     -- A common error is to forget the ForeignFunctionInterface flag
877     -- so check for that, and suggest.  cf Trac #3805
878     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
879     looks_like_foreign (L _ (HsVar v))     = v == foreign_RDR
880     looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
881     looks_like_foreign _                   = False
882
883     foreign_RDR = mkUnqual varName (fsLit "foreign")
884 \end{code}
885
886
887 \begin{code}
888         -- The parser left-associates, so there should 
889         -- not be any OpApps inside the e's
890 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
891 -- Splits (f ! g a b) into (f, [(! g), a, b])
892 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
893   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
894   where
895     (arg1,argns) = split_bang r_arg []
896     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
897     split_bang e                 es = (e,es)
898 splitBang _ = Nothing
899
900 isFunLhs :: LHsExpr RdrName 
901          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
902 -- A variable binding is parsed as a FunBind.
903 -- Just (fun, is_infix, arg_pats) if e is a function LHS
904 --
905 -- The whole LHS is parsed as a single expression.  
906 -- Any infix operators on the LHS will parse left-associatively
907 -- E.g.         f !x y !z
908 --      will parse (rather strangely) as 
909 --              (f ! x y) ! z
910 --      It's up to isFunLhs to sort out the mess
911 --
912 -- a .!. !b 
913
914 isFunLhs e = go e []
915  where
916    go (L loc (HsVar f)) es 
917         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
918    go (L _ (HsApp f e)) es       = go f (e:es)
919    go (L _ (HsPar e))   es@(_:_) = go e es
920
921         -- For infix function defns, there should be only one infix *function*
922         -- (though there may be infix *datacons* involved too).  So we don't
923         -- need fixity info to figure out which function is being defined.
924         --      a `K1` b `op` c `K2` d
925         -- must parse as
926         --      (a `K1` b) `op` (c `K2` d)
927         -- The renamer checks later that the precedences would yield such a parse.
928         -- 
929         -- There is a complication to deal with bang patterns.
930         --
931         -- ToDo: what about this?
932         --              x + 1 `op` y = ...
933
934    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
935         | Just (e',es') <- splitBang e
936         = do { bang_on <- extension bangPatEnabled
937              ; if bang_on then go e' (es' ++ es)
938                else return (Just (L loc' op, True, (l:r:es))) }
939                 -- No bangs; behave just like the next case
940         | not (isRdrDataCon op)         -- We have found the function!
941         = return (Just (L loc' op, True, (l:r:es)))
942         | otherwise                     -- Infix data con; keep going
943         = do { mb_l <- go l es
944              ; case mb_l of
945                  Just (op', True, j : k : es')
946                     -> return (Just (op', True, j : op_app : es'))
947                     where
948                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
949                  _ -> return Nothing }
950    go _ _ = return Nothing
951
952 ---------------------------------------------------------------------------
953 -- Miscellaneous utilities
954
955 checkPrecP :: Located Int -> P Int
956 checkPrecP (L l i)
957  | 0 <= i && i <= maxPrecedence = return i
958  | otherwise                    = parseError l "Precedence out of range"
959
960 mkRecConstrOrUpdate 
961         :: LHsExpr RdrName 
962         -> SrcSpan
963         -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
964         -> P (HsExpr RdrName)
965
966 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
967   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
968 mkRecConstrOrUpdate exp loc (fs,dd)
969   | null fs   = parseError loc "Empty record update"
970   | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
971
972 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
973 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
974 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
975
976 mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
977 -- The Maybe is because the user can omit the activation spec (and usually does)
978 mkInlinePragma mb_act match_info inl 
979   = InlinePragma { inl_inline = inl
980                  , inl_sat    = Nothing
981                  , inl_act    = act
982                  , inl_rule   = match_info }
983   where
984     act = case mb_act of
985             Just act -> act
986             Nothing | inl       -> AlwaysActive
987                     | otherwise -> NeverActive
988         -- If no specific phase is given then:
989         --   NOINLINE => NeverActive
990         --   INLINE   => Active
991
992 -----------------------------------------------------------------------------
993 -- utilities for foreign declarations
994
995 -- construct a foreign import declaration
996 --
997 mkImport :: CCallConv
998          -> Safety 
999          -> (Located FastString, Located RdrName, LHsType RdrName) 
1000          -> P (HsDecl RdrName)
1001 mkImport cconv safety (L loc entity, v, ty)
1002   | cconv == PrimCallConv                      = do
1003   let funcTarget = CFunction (StaticTarget entity Nothing)
1004       importSpec = CImport PrimCallConv safety nilFS funcTarget
1005   return (ForD (ForeignImport v ty importSpec))
1006
1007   | otherwise = do
1008     case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
1009       Nothing         -> parseError loc "Malformed entity string"
1010       Just importSpec -> return (ForD (ForeignImport v ty importSpec))
1011
1012 -- the string "foo" is ambigous: either a header or a C identifier.  The
1013 -- C identifier case comes first in the alternatives below, so we pick
1014 -- that one.
1015 parseCImport :: CCallConv -> Safety -> FastString -> String
1016              -> Maybe ForeignImport
1017 parseCImport cconv safety nm str =
1018  listToMaybe $ map fst $ filter (null.snd) $ 
1019      readP_to_S parse str
1020  where
1021    parse = do
1022        skipSpaces
1023        r <- choice [
1024           string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
1025           string "wrapper" >> return (mk nilFS CWrapper),
1026           optional (string "static" >> skipSpaces) >> 
1027            (mk nilFS <$> cimp nm) +++
1028            (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
1029          ]
1030        skipSpaces
1031        return r
1032
1033    mk = CImport cconv safety
1034
1035    hdr_char c = not (isSpace c) -- header files are filenames, which can contain
1036                                 -- pretty much any char (depending on the platform),
1037                                 -- so just accept any non-space character
1038    id_char  c = isAlphaNum c || c == '_'
1039
1040    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1041              +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
1042           where 
1043             cid = return nm +++
1044                   (do c  <- satisfy (\c -> isAlpha c || c == '_')
1045                       cs <-  many (satisfy id_char)
1046                       return (mkFastString (c:cs)))
1047
1048
1049 -- construct a foreign export declaration
1050 --
1051 mkExport :: CCallConv
1052          -> (Located FastString, Located RdrName, LHsType RdrName) 
1053          -> P (HsDecl RdrName)
1054 mkExport cconv (L _ entity, v, ty) = return $
1055   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1056   where
1057     entity' | nullFS entity = mkExtName (unLoc v)
1058             | otherwise     = entity
1059
1060 -- Supplying the ext_name in a foreign decl is optional; if it
1061 -- isn't there, the Haskell name is assumed. Note that no transformation
1062 -- of the Haskell name is then performed, so if you foreign export (++),
1063 -- it's external name will be "++". Too bad; it's important because we don't
1064 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1065 --
1066 mkExtName :: RdrName -> CLabelString
1067 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1068 \end{code}
1069
1070
1071 -----------------------------------------------------------------------------
1072 -- Misc utils
1073
1074 \begin{code}
1075 parseError :: SrcSpan -> String -> P a
1076 parseError span s = parseErrorSDoc span (text s)
1077
1078 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1079 parseErrorSDoc span s = failSpanMsgP span s
1080 \end{code}