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