Add tuple sections as a new feature
[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 
781      | all tupArgPresent es  -> do ps <- mapM checkLPat [e | Present e <- es]
782                                    return (TuplePat ps b placeHolderType)
783      | otherwise -> parseError loc "Illegal tuple section in pattern"
784    
785    RecordCon c _ (HsRecFields fs dd)
786                       -> do fs <- mapM checkPatField fs
787                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
788    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
789 -- Generics 
790    HsType ty          -> return (TypePat ty) 
791    _                  -> patFail loc
792
793 plus_RDR, bang_RDR :: RdrName
794 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
795 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
796
797 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
798 checkPatField fld = do  { p <- checkLPat (hsRecFieldArg fld)
799                         ; return (fld { hsRecFieldArg = p }) }
800
801 patFail :: SrcSpan -> P a
802 patFail loc = parseError loc "Parse error in pattern"
803
804
805 ---------------------------------------------------------------------------
806 -- Check Equation Syntax
807
808 checkValDef :: LHsExpr RdrName
809             -> Maybe (LHsType RdrName)
810             -> Located (GRHSs RdrName)
811             -> P (HsBind RdrName)
812
813 checkValDef lhs (Just sig) grhss
814         -- x :: ty = rhs  parses as a *pattern* binding
815   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
816
817 checkValDef lhs opt_sig grhss
818   = do  { mb_fun <- isFunLhs lhs
819         ; case mb_fun of
820             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
821                                                 fun is_infix pats opt_sig grhss
822             Nothing -> checkPatBind lhs grhss }
823
824 checkFunBind :: SrcSpan
825              -> Located RdrName
826              -> Bool
827              -> [LHsExpr RdrName]
828              -> Maybe (LHsType RdrName)
829              -> Located (GRHSs RdrName)
830              -> P (HsBind RdrName)
831 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
832   | isQual (unLoc fun)
833   = parseErrorSDoc (getLoc fun) 
834         (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
835   | otherwise
836   = do  ps <- checkPatterns pats
837         let match_span = combineSrcSpans lhs_loc rhs_span
838         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
839         -- The span of the match covers the entire equation.  
840         -- That isn't quite right, but it'll do for now.
841
842 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
843 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
844 makeFunBind fn is_infix ms 
845   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
846               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
847
848 checkPatBind :: LHsExpr RdrName
849              -> Located (GRHSs RdrName)
850              -> P (HsBind RdrName)
851 checkPatBind lhs (L _ grhss)
852   = do  { lhs <- checkPattern lhs
853         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
854
855 checkValSig
856         :: LHsExpr RdrName
857         -> LHsType RdrName
858         -> P (Sig RdrName)
859 checkValSig (L l (HsVar v)) ty 
860   | isUnqual v && not (isDataOcc (rdrNameOcc v))
861   = return (TypeSig (L l v) ty)
862 checkValSig (L l _)         _
863   = parseError l "Invalid type signature"
864 \end{code}
865
866
867 \begin{code}
868         -- The parser left-associates, so there should 
869         -- not be any OpApps inside the e's
870 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
871 -- Splits (f ! g a b) into (f, [(! g), a, b])
872 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
873   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
874   where
875     (arg1,argns) = split_bang r_arg []
876     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
877     split_bang e                 es = (e,es)
878 splitBang _ = Nothing
879
880 isFunLhs :: LHsExpr RdrName 
881          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
882 -- A variable binding is parsed as a FunBind.
883 -- Just (fun, is_infix, arg_pats) if e is a function LHS
884 --
885 -- The whole LHS is parsed as a single expression.  
886 -- Any infix operators on the LHS will parse left-associatively
887 -- E.g.         f !x y !z
888 --      will parse (rather strangely) as 
889 --              (f ! x y) ! z
890 --      It's up to isFunLhs to sort out the mess
891 --
892 -- a .!. !b 
893
894 isFunLhs e = go e []
895  where
896    go (L loc (HsVar f)) es 
897         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
898    go (L _ (HsApp f e)) es       = go f (e:es)
899    go (L _ (HsPar e))   es@(_:_) = go e es
900
901         -- For infix function defns, there should be only one infix *function*
902         -- (though there may be infix *datacons* involved too).  So we don't
903         -- need fixity info to figure out which function is being defined.
904         --      a `K1` b `op` c `K2` d
905         -- must parse as
906         --      (a `K1` b) `op` (c `K2` d)
907         -- The renamer checks later that the precedences would yield such a parse.
908         -- 
909         -- There is a complication to deal with bang patterns.
910         --
911         -- ToDo: what about this?
912         --              x + 1 `op` y = ...
913
914    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
915         | Just (e',es') <- splitBang e
916         = do { bang_on <- extension bangPatEnabled
917              ; if bang_on then go e' (es' ++ es)
918                else return (Just (L loc' op, True, (l:r:es))) }
919                 -- No bangs; behave just like the next case
920         | not (isRdrDataCon op)         -- We have found the function!
921         = return (Just (L loc' op, True, (l:r:es)))
922         | otherwise                     -- Infix data con; keep going
923         = do { mb_l <- go l es
924              ; case mb_l of
925                  Just (op', True, j : k : es')
926                     -> return (Just (op', True, j : op_app : es'))
927                     where
928                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
929                  _ -> return Nothing }
930    go _ _ = return Nothing
931
932 ---------------------------------------------------------------------------
933 -- Miscellaneous utilities
934
935 checkPrecP :: Located Int -> P Int
936 checkPrecP (L l i)
937  | 0 <= i && i <= maxPrecedence = return i
938  | otherwise                    = parseError l "Precedence out of range"
939
940 mkRecConstrOrUpdate 
941         :: LHsExpr RdrName 
942         -> SrcSpan
943         -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
944         -> P (HsExpr RdrName)
945
946 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
947   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
948 mkRecConstrOrUpdate exp loc (fs,dd)
949   | null fs   = parseError loc "Empty record update"
950   | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
951
952 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
953 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
954 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
955
956 mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
957 -- The Maybe is becuase the user can omit the activation spec (and usually does)
958 mkInlineSpec Nothing    match_info True  = alwaysInlineSpec match_info
959                                                                 -- INLINE
960 mkInlineSpec Nothing    match_info False = neverInlineSpec  match_info
961                                                                 -- NOINLINE
962 mkInlineSpec (Just act) match_info inl   = Inline (InlinePragma act match_info) inl
963
964 -----------------------------------------------------------------------------
965 -- utilities for foreign declarations
966
967 -- supported calling conventions
968 --
969 data CallConv = CCall  CCallConv        -- ccall or stdcall
970               | DNCall                  -- .NET
971
972 -- construct a foreign import declaration
973 --
974 mkImport :: CallConv 
975          -> Safety 
976          -> (Located FastString, Located RdrName, LHsType RdrName) 
977          -> P (HsDecl RdrName)
978 mkImport (CCall  cconv) safety (entity, v, ty)
979   | cconv == PrimCallConv                      = do
980   let funcTarget = CFunction (StaticTarget (unLoc entity))
981       importSpec = CImport PrimCallConv safety nilFS funcTarget
982   return (ForD (ForeignImport v ty importSpec))
983   | otherwise = do
984     importSpec <- parseCImport entity cconv safety v
985     return (ForD (ForeignImport v ty importSpec))
986 mkImport (DNCall      ) _      (entity, v, ty) = do
987   spec <- parseDImport entity
988   return $ ForD (ForeignImport v ty (DNImport spec))
989
990 -- parse the entity string of a foreign import declaration for the `ccall' or
991 -- `stdcall' calling convention'
992 --
993 parseCImport :: Located FastString
994              -> CCallConv 
995              -> Safety 
996              -> Located RdrName
997              -> P ForeignImport
998 parseCImport (L loc entity) cconv safety v
999   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
1000   | entity == fsLit "dynamic" = 
1001     return $ CImport cconv safety nilFS (CFunction DynamicTarget)
1002   | entity == fsLit "wrapper" =
1003     return $ CImport cconv safety nilFS CWrapper
1004   | otherwise                  = parse0 (unpackFS entity)
1005     where
1006       -- using the static keyword?
1007       parse0 (' ':                    rest) = parse0 rest
1008       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
1009       parse0                          rest  = parse1 rest
1010       -- check for header file name
1011       parse1     ""               = parse4 ""    nilFS        False
1012       parse1     (' ':rest)       = parse1 rest
1013       parse1 str@('&':_   )       = parse2 str   nilFS
1014       parse1 str
1015         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
1016         | otherwise               = parse4 str   nilFS        False
1017         where
1018           (first, rest) = break (\c -> c == ' ' || c == '&') str
1019       -- check for address operator (indicating a label import)
1020       parse2     ""         header = parse4 ""   header False
1021       parse2     (' ':rest) header = parse2 rest header
1022       parse2     ('&':rest) header = parse3 rest header
1023       parse2 str            header = parse4 str  header False
1024       -- eat spaces after '&'
1025       parse3 (' ':rest) header = parse3 rest header 
1026       parse3 str        header = parse4 str  header True
1027       -- check for name of C function
1028       parse4 ""         header isLbl = build (mkExtName (unLoc v)) header isLbl
1029       parse4 (' ':rest) header isLbl = parse4 rest                 header isLbl
1030       parse4 str        header isLbl
1031         | all (== ' ') rest = build (mkFastString first)  header isLbl
1032         | otherwise         = parseError loc "Malformed entity string"
1033         where
1034           (first, rest) = break (== ' ') str
1035       --
1036       build cid header False = return $
1037         CImport cconv safety header (CFunction (StaticTarget cid))
1038       build cid header True  = return $
1039         CImport cconv safety header (CLabel                  cid )
1040
1041 --
1042 -- Unravel a dotnet spec string.
1043 --
1044 parseDImport :: Located FastString -> P DNCallSpec
1045 parseDImport (L loc entity) = parse0 comps
1046  where
1047   comps = words (unpackFS entity)
1048
1049   parse0 [] = d'oh
1050   parse0 (x : xs) 
1051     | x == "static" = parse1 True xs
1052     | otherwise     = parse1 False (x:xs)
1053
1054   parse1 _ [] = d'oh
1055   parse1 isStatic (x:xs)
1056     | x == "method" = parse2 isStatic DNMethod xs
1057     | x == "field"  = parse2 isStatic DNField xs
1058     | x == "ctor"   = parse2 isStatic DNConstructor xs
1059   parse1 isStatic xs = parse2 isStatic DNMethod xs
1060
1061   parse2 _ _ [] = d'oh
1062   parse2 isStatic kind (('[':x):xs) =
1063      case x of
1064         [] -> d'oh
1065         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
1066         _ -> d'oh
1067   parse2 isStatic kind xs = parse3 isStatic kind "" xs
1068
1069   parse3 isStatic kind assem [x] = 
1070     return (DNCallSpec isStatic kind assem x 
1071                           -- these will be filled in once known.
1072                         (error "FFI-dotnet-args")
1073                         (error "FFI-dotnet-result"))
1074   parse3 _ _ _ _ = d'oh
1075
1076   d'oh = parseError loc "Malformed entity string"
1077   
1078 -- construct a foreign export declaration
1079 --
1080 mkExport :: CallConv
1081          -> (Located FastString, Located RdrName, LHsType RdrName) 
1082          -> P (HsDecl RdrName)
1083 mkExport (CCall  cconv) (L _ entity, v, ty) = return $
1084   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1085   where
1086     entity' | nullFS entity = mkExtName (unLoc v)
1087             | otherwise     = entity
1088 mkExport DNCall (L _ _, v, _) =
1089   parseError (getLoc v){-TODO: not quite right-}
1090         "Foreign export is not yet supported for .NET"
1091
1092 -- Supplying the ext_name in a foreign decl is optional; if it
1093 -- isn't there, the Haskell name is assumed. Note that no transformation
1094 -- of the Haskell name is then performed, so if you foreign export (++),
1095 -- it's external name will be "++". Too bad; it's important because we don't
1096 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1097 --
1098 mkExtName :: RdrName -> CLabelString
1099 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1100 \end{code}
1101
1102
1103 -----------------------------------------------------------------------------
1104 -- Misc utils
1105
1106 \begin{code}
1107 parseError :: SrcSpan -> String -> P a
1108 parseError span s = parseErrorSDoc span (text s)
1109
1110 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1111 parseErrorSDoc span s = failSpanMsgP span s
1112 \end{code}