Remove the DocEntity type. Fixes the problem with duplicate error messages at
[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], [LDocDecl 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, docs)
226                             where (bs, ss, ts, docs) = go ds
227     go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, 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 l (DocD d) : ds)     =  (bs, ss, ts, (L l 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}) 
308     l (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, hs_fixds = fsigs ++ fs}) ds
312         | isFamInstDecl d = 
313                 addl (gp { hs_tyclds = L l d : ts }) ds
314         | otherwise =
315                 addl (gp { hs_tyclds = L l d : ts }) ds
316
317 -- Signatures: fixity sigs go a different place than all others
318 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
319   = addl (gp {hs_fixds = L l f : ts}) ds
320 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
321   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
322
323 -- Value declarations: use add_bind
324 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
325   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
326
327 -- The rest are routine
328 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
329   = addl (gp { hs_instds = L l d : ts }) ds
330 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
331   = addl (gp { hs_derivds = L l d : ts }) ds
332 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
333   = addl (gp { hs_defds = L l d : ts }) ds
334 add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
335   = addl (gp { hs_fords = L l d : ts }) ds
336 add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
337   = addl (gp { hs_depds = L l d : ts }) ds
338 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
339   = addl (gp { hs_ruleds = L l d : ts }) ds
340
341 add gp l (DocD d) ds
342   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
343
344 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
345 add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs               (s:sigs) 
346 \end{code}
347
348 %************************************************************************
349 %*                                                                      *
350 \subsection[PrefixToHS-utils]{Utilities for conversion}
351 %*                                                                      *
352 %************************************************************************
353
354
355 \begin{code}
356 -----------------------------------------------------------------------------
357 -- mkPrefixCon
358
359 -- When parsing data declarations, we sometimes inadvertently parse
360 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
361 -- This function splits up the type application, adds any pending
362 -- arguments, and converts the type constructor back into a data constructor.
363
364 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
365   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
366 mkPrefixCon ty tys
367  = split ty tys
368  where
369    split (L _ (HsAppTy t u)) ts = split t (u : ts)
370    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
371                                      return (data_con, PrefixCon ts)
372    split (L l _) _              = parseError l "parse error in data/newtype declaration"
373
374 mkRecCon :: Located RdrName -> 
375             [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
376             P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
377 mkRecCon (L loc con) fields
378   = do data_con <- tyConToDataCon loc con
379        return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
380
381 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
382 tyConToDataCon loc tc
383   | isTcOcc (rdrNameOcc tc)
384   = return (L loc (setRdrNameSpace tc srcDataName))
385   | otherwise
386   = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
387
388 ----------------------------------------------------------------------------
389 -- Various Syntactic Checks
390
391 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
392 checkInstType (L l t)
393   = case t of
394         HsForAllTy exp tvs ctxt ty -> do
395                 dict_ty <- checkDictTy ty
396                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
397
398         HsParTy ty -> checkInstType ty
399
400         ty ->   do dict_ty <- checkDictTy (L l ty)
401                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
402
403 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
404 checkDictTy (L spn ty) = check ty []
405   where
406   check (HsTyVar t) args | not (isRdrTyVar t) 
407         = return (L spn (HsPredTy (HsClassP t args)))
408   check (HsAppTy l r) args = check (unLoc l) (r:args)
409   check (HsParTy t)   args = check (unLoc t) args
410   check _ _ = parseError spn "Malformed instance header"
411
412 -- Check whether the given list of type parameters are all type variables
413 -- (possibly with a kind signature).  If the second argument is `False',
414 -- only type variables are allowed and we raise an error on encountering a
415 -- non-variable; otherwise, we allow non-variable arguments and return the
416 -- entire list of parameters.
417 --
418 checkTyVars :: [LHsType RdrName] -> P ()
419 checkTyVars tparms = mapM_ chk tparms
420   where
421         -- Check that the name space is correct!
422     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
423         | isRdrTyVar tv    = return ()
424     chk (L l (HsTyVar tv))
425         | isRdrTyVar tv    = return ()
426     chk (L l other)        =
427           parseError l "Type found where type variable expected"
428
429 -- Check whether the type arguments in a type synonym head are simply
430 -- variables.  If not, we have a type equation of a type function and return
431 -- all patterns.  If yes, we return 'Nothing' as the third component to
432 -- indicate a vanilla type synonym.
433 --
434 checkSynHdr :: LHsType RdrName 
435             -> Bool                             -- is type instance?
436             -> P (Located RdrName,              -- head symbol
437                   [LHsTyVarBndr RdrName],       -- parameters
438                   [LHsType RdrName])            -- type patterns
439 checkSynHdr ty isTyInst = 
440   do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
441      ; unless isTyInst $ checkTyVars tparms
442      ; return (tc, tvs, tparms) }
443
444
445 -- Well-formedness check and decomposition of type and class heads.
446 --
447 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
448   -> P (LHsContext RdrName,          -- the type context
449         Located RdrName,             -- the head symbol (type or class name)
450         [LHsTyVarBndr RdrName],      -- free variables of the non-context part
451         [LHsType RdrName])           -- parameters of head symbol
452 -- The header of a type or class decl should look like
453 --      (C a, D b) => T a b
454 -- or   T a b
455 -- or   a + b
456 -- etc
457 -- With associated types, we can also have non-variable parameters; ie,
458 --      T Int [a]
459 -- The unaltered parameter list is returned in the fourth component of the
460 -- result.  Eg, for
461 --      T Int [a]
462 -- we return
463 --      ('()', 'T', ['a'], ['Int', '[a]'])
464 checkTyClHdr (L l cxt) ty
465   = do (tc, tvs, parms) <- gol ty []
466        mapM_ chk_pred cxt
467        return (L l cxt, tc, tvs, parms)
468   where
469     gol (L l ty) acc = go l ty acc
470
471     go l (HsTyVar tc)    acc 
472         | not (isRdrTyVar tc)   = do
473                                     tvs <- extractTyVars acc
474                                     return (L l tc, tvs, acc)
475     go l (HsOpTy t1 tc t2) acc  = do
476                                     tvs <- extractTyVars (t1:t2:acc)
477                                     return (tc, tvs, acc)
478     go l (HsParTy ty)    acc    = gol ty acc
479     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
480     go l other           acc    = 
481       parseError l "Malformed head of type or class declaration"
482
483         -- The predicates in a type or class decl must be class predicates or 
484         -- equational constraints.  They need not all have variable-only
485         -- arguments, even in Haskell 98.  
486         -- E.g. class (Monad m, Monad (t m)) => MonadT t m
487     chk_pred (L l (HsClassP _ _)) = return ()
488     chk_pred (L l (HsEqualP _ _)) = return ()
489     chk_pred (L l _)
490        = parseError l "Malformed context in type or class declaration"
491
492 -- Extract the type variables of a list of type parameters.
493 --
494 -- * Type arguments can be complex type terms (needed for associated type
495 --   declarations).
496 --
497 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
498 extractTyVars tvs = collects [] tvs
499   where
500         -- Collect all variables (1st arg serves as an accumulator)
501     collect tvs (L l (HsForAllTy _ _ _ _)) =
502       parseError l "Forall type not allowed as type parameter"
503     collect tvs (L l (HsTyVar tv))
504       | isRdrTyVar tv                      = return $ L l (UserTyVar tv) : tvs
505       | otherwise                          = return tvs
506     collect tvs (L l (HsBangTy _ _      )) =
507       parseError l "Bang-style type annotations not allowed as type parameter"
508     collect tvs (L l (HsAppTy t1 t2     )) = do
509                                                tvs' <- collect tvs t2
510                                                collect tvs' t1
511     collect tvs (L l (HsFunTy t1 t2     )) = do
512                                                tvs' <- collect tvs t2
513                                                collect tvs' t1
514     collect tvs (L l (HsListTy t        )) = collect tvs t
515     collect tvs (L l (HsPArrTy t        )) = collect tvs t
516     collect tvs (L l (HsTupleTy _ ts    )) = collects tvs ts
517     collect tvs (L l (HsOpTy t1 _ t2    )) = do
518                                                tvs' <- collect tvs t2
519                                                collect tvs' t1
520     collect tvs (L l (HsParTy t         )) = collect tvs t
521     collect tvs (L l (HsNumTy t         )) = return tvs
522     collect tvs (L l (HsPredTy t        )) = 
523       parseError l "Predicate not allowed as type parameter"
524     collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
525         | isRdrTyVar tv                    = 
526           return $ L l (KindedTyVar tv k) : tvs
527         | otherwise                        =
528           parseError l "Kind signature only allowed for type variables"
529     collect tvs (L l (HsSpliceTy t      )) = 
530       parseError l "Splice not allowed as type parameter"
531
532         -- Collect all variables of a list of types
533     collects tvs []     = return tvs
534     collects tvs (t:ts) = do
535                             tvs' <- collects tvs ts
536                             collect tvs' t
537
538 -- Check that associated type declarations of a class are all kind signatures.
539 --
540 checkKindSigs :: [LTyClDecl RdrName] -> P ()
541 checkKindSigs = mapM_ check
542   where
543     check (L l tydecl) 
544       | isFamilyDecl tydecl
545         || isSynDecl tydecl  = return ()
546       | otherwise            = 
547         parseError l "Type declaration in a class must be a kind signature or synonym default"
548
549 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
550 checkContext (L l t)
551   = check t
552  where
553   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
554     = do ctx <- mapM checkPred ts
555          return (L l ctx)
556
557   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
558     = check (unLoc ty)
559
560   check (HsTyVar t)     -- Empty context shows up as a unit type ()
561     | t == getRdrName unitTyCon = return (L l [])
562
563   check t 
564     = do p <- checkPred (L l t)
565          return (L l [p])
566
567
568 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
569 -- Watch out.. in ...deriving( Show )... we use checkPred on 
570 -- the list of partially applied predicates in the deriving,
571 -- so there can be zero args.
572 checkPred (L spn (HsPredTy (HsIParam n ty)))
573   = return (L spn (HsIParam n ty))
574 checkPred (L spn ty)
575   = check spn ty []
576   where
577     checkl (L l ty) args = check l ty args
578
579     check _loc (HsPredTy pred@(HsEqualP _ _)) 
580                                        args | null args
581                                             = return $ L spn pred
582     check _loc (HsTyVar t)             args | not (isRdrTyVar t) 
583                                             = return (L spn (HsClassP t args))
584     check _loc (HsAppTy l r)           args = checkl l (r:args)
585     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
586     check _loc (HsParTy t)             args = checkl t args
587     check loc _                        _    = parseError loc  
588                                                 "malformed class assertion"
589
590 ---------------------------------------------------------------------------
591 -- Checking stand-alone deriving declarations
592
593 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
594 checkDerivDecl d@(L loc _) = 
595     do glaExtOn <- extension glaExtsEnabled
596        if glaExtOn then return d
597          else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
598
599 ---------------------------------------------------------------------------
600 -- Checking statements in a do-expression
601 --      We parse   do { e1 ; e2 ; }
602 --      as [ExprStmt e1, ExprStmt e2]
603 -- checkDo (a) checks that the last thing is an ExprStmt
604 --         (b) returns it separately
605 -- same comments apply for mdo as well
606
607 checkDo  = checkDoMDo "a " "'do'"
608 checkMDo = checkDoMDo "an " "'mdo'"
609
610 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
611 checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
612 checkDoMDo pre nm loc ss   = do 
613   check ss
614   where 
615         check  [L l (ExprStmt e _ _)] = return ([], e)
616         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
617                                          " construct must be an expression")
618         check (s:ss) = do
619           (ss',e') <-  check ss
620           return ((s:ss'),e')
621
622 -- -------------------------------------------------------------------------
623 -- Checking Patterns.
624
625 -- We parse patterns as expressions and check for valid patterns below,
626 -- converting the expression into a pattern at the same time.
627
628 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
629 checkPattern e = checkLPat e
630
631 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
632 checkPatterns es = mapM checkPattern es
633
634 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
635 checkLPat e@(L l _) = checkPat l e []
636
637 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
638 checkPat loc (L l (HsVar c)) args
639   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
640 checkPat loc e args     -- OK to let this happen even if bang-patterns
641                         -- are not enabled, because there is no valid
642                         -- non-bang-pattern parse of (C ! e)
643   | Just (e', args') <- splitBang e
644   = do  { args'' <- checkPatterns args'
645         ; checkPat loc e' (args'' ++ args) }
646 checkPat loc (L _ (HsApp f x)) args
647   = do { x <- checkLPat x; checkPat loc f (x:args) }
648 checkPat loc (L _ e) []
649   = do { p <- checkAPat loc e; return (L loc p) }
650 checkPat loc pat _some_args
651   = patFail loc
652
653 checkAPat loc e = case e of
654    EWildPat            -> return (WildPat placeHolderType)
655    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
656                                          ++ showRdrName x)
657            | otherwise -> return (VarPat x)
658    HsLit l             -> return (LitPat l)
659
660    -- Overloaded numeric patterns (e.g. f 0 x = x)
661    -- Negation is recorded separately, so that the literal is zero or +ve
662    -- NB. Negative *primitive* literals are already handled by
663    --     RdrHsSyn.mkHsNegApp
664    HsOverLit pos_lit            -> return (mkNPat pos_lit Nothing)
665    NegApp (L _ (HsOverLit pos_lit)) _ 
666                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
667    
668    SectionR (L _ (HsVar bang)) e        -- (! x)
669         | bang == bang_RDR 
670         -> do { bang_on <- extension bangPatEnabled
671               ; if bang_on then checkLPat e >>= (return . BangPat)
672                 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
673
674    ELazyPat e         -> checkLPat e >>= (return . LazyPat)
675    EAsPat n e         -> checkLPat e >>= (return . AsPat n)
676    ExprWithTySig e t  -> checkLPat e >>= \e ->
677                          -- Pattern signatures are parsed as sigtypes,
678                          -- but they aren't explicit forall points.  Hence
679                          -- we have to remove the implicit forall here.
680                          let t' = case t of 
681                                      L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
682                                      other -> other
683                          in
684                          return (SigPatIn e t')
685    
686    -- n+k patterns
687    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ 
688         (L _ (HsOverLit lit@(HsIntegral _ _)))
689                       | plus == plus_RDR
690                       -> return (mkNPlusKPat (L nloc n) lit)
691    
692    OpApp l op fix r   -> checkLPat l >>= \l ->
693                          checkLPat r >>= \r ->
694                          case op of
695                             L cl (HsVar c) | isDataOcc (rdrNameOcc c)
696                                    -> return (ConPatIn (L cl c) (InfixCon l r))
697                             _ -> patFail loc
698    
699    HsPar e                 -> checkLPat e >>= (return . ParPat)
700    ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
701                          return (ListPat ps placeHolderType)
702    ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
703                          return (PArrPat ps placeHolderType)
704    
705    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
706                          return (TuplePat ps b placeHolderType)
707    
708    RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
709                          return (ConPatIn c (RecCon (map (uncurry mkRecField) fs))) 
710 -- Generics 
711    HsType ty          -> return (TypePat ty) 
712    _                  -> patFail loc
713
714 plus_RDR, bang_RDR :: RdrName
715 plus_RDR = mkUnqual varName FSLIT("+")  -- Hack
716 bang_RDR = mkUnqual varName FSLIT("!")  -- Hack
717
718 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
719 checkPatField (n,e) = do
720   p <- checkLPat e
721   return (n,p)
722
723 patFail loc = parseError loc "Parse error in pattern"
724
725
726 ---------------------------------------------------------------------------
727 -- Check Equation Syntax
728
729 checkValDef :: LHsExpr RdrName
730             -> Maybe (LHsType RdrName)
731             -> Located (GRHSs RdrName)
732             -> P (HsBind RdrName)
733
734 checkValDef lhs (Just sig) grhss
735         -- x :: ty = rhs  parses as a *pattern* binding
736   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
737
738 checkValDef lhs opt_sig grhss
739   = do  { mb_fun <- isFunLhs lhs
740         ; case mb_fun of
741             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
742                                                 fun is_infix pats opt_sig grhss
743             Nothing -> checkPatBind lhs grhss }
744
745 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
746   | isQual (unLoc fun)
747   = parseError (getLoc fun) ("Qualified name in function definition: "  ++ 
748                              showRdrName (unLoc fun))
749   | otherwise
750   = do  ps <- checkPatterns pats
751         let match_span = combineSrcSpans lhs_loc rhs_span
752         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
753         -- The span of the match covers the entire equation.  
754         -- That isn't quite right, but it'll do for now.
755
756 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
757 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
758 makeFunBind fn is_infix ms 
759   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
760               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
761
762 checkPatBind lhs (L _ grhss)
763   = do  { lhs <- checkPattern lhs
764         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
765
766 checkValSig
767         :: LHsExpr RdrName
768         -> LHsType RdrName
769         -> P (Sig RdrName)
770 checkValSig (L l (HsVar v)) ty 
771   | isUnqual v && not (isDataOcc (rdrNameOcc v))
772   = return (TypeSig (L l v) ty)
773 checkValSig (L l other)     ty
774   = parseError l "Invalid type signature"
775
776 mkGadtDecl :: Located RdrName
777            -> LHsType RdrName -- assuming HsType
778            -> ConDecl RdrName
779 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
780 mkGadtDecl name ty                                = mk_gadt_con name [] (noLoc []) ty
781
782 mk_gadt_con name qvars cxt ty
783   = ConDecl { con_name     = name
784             , con_explicit = Implicit
785             , con_qvars    = qvars
786             , con_cxt      = cxt
787             , con_details  = PrefixCon []
788             , con_res      = ResTyGADT ty
789             , con_doc      = Nothing }
790   -- NB: we put the whole constr type into the ResTyGADT for now; 
791   -- the renamer will unravel it once it has sorted out
792   -- operator fixities
793
794 -- A variable binding is parsed as a FunBind.
795
796
797         -- The parser left-associates, so there should 
798         -- not be any OpApps inside the e's
799 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
800 -- Splits (f ! g a b) into (f, [(! g), a, g])
801 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
802   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
803   where
804     (arg1,argns) = split_bang r_arg []
805     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
806     split_bang e                 es = (e,es)
807 splitBang other = Nothing
808
809 isFunLhs :: LHsExpr RdrName 
810          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
811 -- Just (fun, is_infix, arg_pats) if e is a function LHS
812 isFunLhs e = go e []
813  where
814    go (L loc (HsVar f)) es 
815         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
816    go (L _ (HsApp f e)) es       = go f (e:es)
817    go (L _ (HsPar e))   es@(_:_) = go e es
818
819         -- For infix function defns, there should be only one infix *function*
820         -- (though there may be infix *datacons* involved too).  So we don't
821         -- need fixity info to figure out which function is being defined.
822         --      a `K1` b `op` c `K2` d
823         -- must parse as
824         --      (a `K1` b) `op` (c `K2` d)
825         -- The renamer checks later that the precedences would yield such a parse.
826         -- 
827         -- There is a complication to deal with bang patterns.
828         --
829         -- ToDo: what about this?
830         --              x + 1 `op` y = ...
831
832    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
833         | Just (e',es') <- splitBang e
834         = do { bang_on <- extension bangPatEnabled
835              ; if bang_on then go e' (es' ++ es)
836                else return (Just (L loc' op, True, (l:r:es))) }
837                 -- No bangs; behave just like the next case
838         | not (isRdrDataCon op)         -- We have found the function!
839         = return (Just (L loc' op, True, (l:r:es)))
840         | otherwise                     -- Infix data con; keep going
841         = do { mb_l <- go l es
842              ; case mb_l of
843                  Just (op', True, j : k : es')
844                     -> return (Just (op', True, j : op_app : es'))
845                     where
846                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
847                  _ -> return Nothing }
848    go _ _ = return Nothing
849
850 ---------------------------------------------------------------------------
851 -- Miscellaneous utilities
852
853 checkPrecP :: Located Int -> P Int
854 checkPrecP (L l i)
855  | 0 <= i && i <= maxPrecedence = return i
856  | otherwise                    = parseError l "Precedence out of range"
857
858 mkRecConstrOrUpdate 
859         :: LHsExpr RdrName 
860         -> SrcSpan
861         -> HsRecordBinds RdrName
862         -> P (HsExpr RdrName)
863
864 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
865   = return (RecordCon (L l c) noPostTcExpr fs)
866 mkRecConstrOrUpdate exp loc fs@(_:_)
867   = return (RecordUpd exp fs placeHolderType placeHolderType)
868 mkRecConstrOrUpdate _ loc []
869   = parseError loc "Empty record update"
870
871 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
872 -- The Maybe is becuase the user can omit the activation spec (and usually does)
873 mkInlineSpec Nothing    True  = alwaysInlineSpec        -- INLINE
874 mkInlineSpec Nothing    False = neverInlineSpec         -- NOINLINE
875 mkInlineSpec (Just act) inl   = Inline act inl
876
877
878 -----------------------------------------------------------------------------
879 -- utilities for foreign declarations
880
881 -- supported calling conventions
882 --
883 data CallConv = CCall  CCallConv        -- ccall or stdcall
884               | DNCall                  -- .NET
885
886 -- construct a foreign import declaration
887 --
888 mkImport :: CallConv 
889          -> Safety 
890          -> (Located FastString, Located RdrName, LHsType RdrName) 
891          -> P (HsDecl RdrName)
892 mkImport (CCall  cconv) safety (entity, v, ty) = do
893   importSpec <- parseCImport entity cconv safety v
894   return (ForD (ForeignImport v ty importSpec))
895 mkImport (DNCall      ) _      (entity, v, ty) = do
896   spec <- parseDImport entity
897   return $ ForD (ForeignImport v ty (DNImport spec))
898
899 -- parse the entity string of a foreign import declaration for the `ccall' or
900 -- `stdcall' calling convention'
901 --
902 parseCImport :: Located FastString
903              -> CCallConv 
904              -> Safety 
905              -> Located RdrName
906              -> P ForeignImport
907 parseCImport (L loc entity) cconv safety v
908   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
909   | entity == FSLIT ("dynamic") = 
910     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
911   | entity == FSLIT ("wrapper") =
912     return $ CImport cconv safety nilFS nilFS CWrapper
913   | otherwise                  = parse0 (unpackFS entity)
914     where
915       -- using the static keyword?
916       parse0 (' ':                    rest) = parse0 rest
917       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
918       parse0                          rest  = parse1 rest
919       -- check for header file name
920       parse1     ""               = parse4 ""    nilFS        False nilFS
921       parse1     (' ':rest)       = parse1 rest
922       parse1 str@('&':_   )       = parse2 str   nilFS
923       parse1 str@('[':_   )       = parse3 str   nilFS        False
924       parse1 str
925         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
926         | otherwise               = parse4 str   nilFS        False nilFS
927         where
928           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
929       -- check for address operator (indicating a label import)
930       parse2     ""         header = parse4 ""   header False nilFS
931       parse2     (' ':rest) header = parse2 rest header
932       parse2     ('&':rest) header = parse3 rest header True
933       parse2 str@('[':_   ) header = parse3 str  header False
934       parse2 str            header = parse4 str  header False nilFS
935       -- check for library object name
936       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
937       parse3 ('[':rest) header isLbl = 
938         case break (== ']') rest of 
939           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
940           _                         -> parseError loc "Missing ']' in entity"
941       parse3 str        header isLbl = parse4 str  header isLbl nilFS
942       -- check for name of C function
943       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
944       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
945       parse4 str        header isLbl lib
946         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
947         | otherwise                      = parseError loc "Malformed entity string"
948         where
949           (first, rest) = break (== ' ') str
950       --
951       build cid header False lib = return $
952         CImport cconv safety header lib (CFunction (StaticTarget cid))
953       build cid header True  lib = return $
954         CImport cconv safety header lib (CLabel                  cid )
955
956 --
957 -- Unravel a dotnet spec string.
958 --
959 parseDImport :: Located FastString -> P DNCallSpec
960 parseDImport (L loc entity) = parse0 comps
961  where
962   comps = words (unpackFS entity)
963
964   parse0 [] = d'oh
965   parse0 (x : xs) 
966     | x == "static" = parse1 True xs
967     | otherwise     = parse1 False (x:xs)
968
969   parse1 _ [] = d'oh
970   parse1 isStatic (x:xs)
971     | x == "method" = parse2 isStatic DNMethod xs
972     | x == "field"  = parse2 isStatic DNField xs
973     | x == "ctor"   = parse2 isStatic DNConstructor xs
974   parse1 isStatic xs = parse2 isStatic DNMethod xs
975
976   parse2 _ _ [] = d'oh
977   parse2 isStatic kind (('[':x):xs) =
978      case x of
979         [] -> d'oh
980         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
981   parse2 isStatic kind xs = parse3 isStatic kind "" xs
982
983   parse3 isStatic kind assem [x] = 
984     return (DNCallSpec isStatic kind assem x 
985                           -- these will be filled in once known.
986                         (error "FFI-dotnet-args")
987                         (error "FFI-dotnet-result"))
988   parse3 _ _ _ _ = d'oh
989
990   d'oh = parseError loc "Malformed entity string"
991   
992 -- construct a foreign export declaration
993 --
994 mkExport :: CallConv
995          -> (Located FastString, Located RdrName, LHsType RdrName) 
996          -> P (HsDecl RdrName)
997 mkExport (CCall  cconv) (L loc entity, v, ty) = return $ 
998   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
999   where
1000     entity' | nullFS entity = mkExtName (unLoc v)
1001             | otherwise     = entity
1002 mkExport DNCall (L loc entity, v, ty) =
1003   parseError (getLoc v){-TODO: not quite right-}
1004         "Foreign export is not yet supported for .NET"
1005
1006 -- Supplying the ext_name in a foreign decl is optional; if it
1007 -- isn't there, the Haskell name is assumed. Note that no transformation
1008 -- of the Haskell name is then performed, so if you foreign export (++),
1009 -- it's external name will be "++". Too bad; it's important because we don't
1010 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1011 --
1012 mkExtName :: RdrName -> CLabelString
1013 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1014 \end{code}
1015
1016
1017 -----------------------------------------------------------------------------
1018 -- Misc utils
1019
1020 \begin{code}
1021 showRdrName :: RdrName -> String
1022 showRdrName r = showSDoc (ppr r)
1023
1024 parseError :: SrcSpan -> String -> P a
1025 parseError span s = failSpanMsgP span s
1026 \end{code}