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