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