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