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