Add -fwarn-context-quantification (#4426)
[ghc.git] / compiler / parser / RdrHsSyn.lhs
1 o%
2 % (c) The University of Glasgow, 1996-2003
3
4 Functions over HsSyn specialised to RdrName.
5
6 \begin{code}
7 {-# LANGUAGE CPP #-}
8 {-# LANGUAGE FlexibleContexts #-}
9
10 module RdrHsSyn (
11         mkHsOpApp,
12         mkHsIntegral, mkHsFractional, mkHsIsString,
13         mkHsDo, mkSpliceDecl,
14         mkRoleAnnotDecl,
15         mkClassDecl, 
16         mkTyData, mkDataFamInst, 
17         mkTySynonym, mkTyFamInstEqn,
18         mkTyFamInst, 
19         mkFamDecl, 
20         splitCon, mkInlinePragma,
21         splitPatSyn, toPatSynMatchGroup,
22         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
23         mkTyLit,
24         mkTyClD, mkInstD,
25
26         cvBindGroup,
27         cvBindsAndSigs,
28         cvTopDecls,
29         placeHolderPunRhs,
30
31         -- Stuff to do with Foreign declarations
32         mkImport,
33         parseCImport,
34         mkExport,
35         mkExtName,           -- RdrName -> CLabelString
36         mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
37         mkSimpleConDecl,
38         mkDeprecatedGadtRecordDecl,
39         mkATDefault,
40
41         -- Bunch of functions in the parser monad for
42         -- checking and constructing values
43         checkPrecP,           -- Int -> P Int
44         checkContext,         -- HsType -> P HsContext
45         checkPattern,         -- HsExp -> P HsPat
46         bang_RDR,
47         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
48         checkMonadComp,       -- P (HsStmtContext RdrName)
49         checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
50         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
51         checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
52         checkDoAndIfThenElse,
53         checkRecordSyntax,
54         parseErrorSDoc,
55
56         -- Help with processing exports
57         ImpExpSubSpec(..),
58         mkModuleImpExp,
59         mkTypeImpExp
60
61     ) where
62
63 import HsSyn            -- Lots of it
64 import Class            ( FunDep )
65 import CoAxiom          ( Role, fsFromRole )
66 import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
67                           isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace,
68                           rdrNameSpace )
69 import OccName          ( tcClsName, isVarNameSpace )
70 import Name             ( Name )
71 import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
72                           InlinePragma(..), InlineSpec(..), Origin(..) )
73 import TcEvidence       ( idHsWrapper )
74 import Lexer
75 import TysWiredIn       ( unitTyCon, unitDataCon )
76 import ForeignCall
77 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
78                           occNameString )
79 import PrelNames        ( forall_tv_RDR, allNameStrings )
80 import DynFlags
81 import SrcLoc
82 import OrdList          ( OrdList, fromOL )
83 import Bag              ( emptyBag, consBag )
84 import Outputable
85 import FastString
86 import Maybes
87 import Util
88
89 import Control.Applicative ((<$>))
90 #if __GLASGOW_HASKELL__ >= 709
91 import Control.Monad hiding (empty, many)
92 #else
93 import Control.Monad
94 #endif
95
96 import Text.ParserCombinators.ReadP as ReadP
97 import Data.Char
98
99 import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
100
101 #include "HsVersions.h"
102 \end{code}
103
104
105 %************************************************************************
106 %*                                                                      *
107 \subsection{Construction functions for Rdr stuff}
108 %*                                                                    *
109 %************************************************************************
110
111 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
112 by deriving them from the name of the class.  We fill in the names for the
113 tycon and datacon corresponding to the class, by deriving them from the
114 name of the class itself.  This saves recording the names in the interface
115 file (which would be equally good).
116
117 Similarly for mkConDecl, mkClassOpSig and default-method names.
118
119         *** See "THE NAMING STORY" in HsDecls ****
120
121 \begin{code}
122 mkTyClD :: LTyClDecl n -> LHsDecl n
123 mkTyClD (L loc d) = L loc (TyClD d)
124
125 mkInstD :: LInstDecl n -> LHsDecl n
126 mkInstD (L loc d) = L loc (InstD d)
127
128 mkClassDecl :: SrcSpan
129             -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
130             -> Located [Located (FunDep RdrName)]
131             -> Located (OrdList (LHsDecl RdrName))
132             -> P (LTyClDecl RdrName)
133
134 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
135   = do { let (binds, sigs, ats, at_insts, _, docs) = cvBindsAndSigs (unLoc where_cls)
136              cxt = fromMaybe (noLoc []) mcxt
137        ; (cls, tparams) <- checkTyClHdr tycl_hdr
138        ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
139        ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
140        ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
141                                     tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
142                                     tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs,
143                                     tcdFVs = placeHolderNames })) }
144
145 mkATDefault :: LTyFamInstDecl RdrName
146             -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName)
147 -- Take a type-family instance declaration and turn it into
148 -- a type-family default equation for a class declaration
149 -- We parse things as the former and use this function to convert to the latter
150 -- 
151 -- We use the Either monad because this also called 
152 -- from Convert.hs
153 mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
154       | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e
155       = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats)
156            ; return (L loc (TyFamEqn { tfe_tycon = tc
157                                      , tfe_pats = tvs
158                                      , tfe_rhs = rhs })) }
159
160 mkTyData :: SrcSpan
161          -> NewOrData
162          -> Maybe CType
163          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
164          -> Maybe (LHsKind RdrName)
165          -> [LConDecl RdrName]
166          -> Maybe [LHsType RdrName]
167          -> P (LTyClDecl RdrName)
168 mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
169   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
170        ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
171        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
172        ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
173                                    tcdDataDefn = defn,
174                                    tcdFVs = placeHolderNames })) }
175
176 mkDataDefn :: NewOrData
177            -> Maybe CType
178            -> Maybe (LHsContext RdrName)
179            -> Maybe (LHsKind RdrName)
180            -> [LConDecl RdrName]
181            -> Maybe [LHsType RdrName]
182            -> P (HsDataDefn RdrName)
183 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
184   = do { checkDatatypeContext mcxt
185        ; let cxt = fromMaybe (noLoc []) mcxt
186        ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
187                             , dd_ctxt = cxt 
188                             , dd_cons = data_cons
189                             , dd_kindSig = ksig
190                             , dd_derivs = maybe_deriv }) }
191
192 mkTySynonym :: SrcSpan
193             -> LHsType RdrName  -- LHS
194             -> LHsType RdrName  -- RHS
195             -> P (LTyClDecl RdrName)
196 mkTySynonym loc lhs rhs
197   = do { (tc, tparams) <- checkTyClHdr lhs
198        ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams
199        ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars
200                                 , tcdRhs = rhs, tcdFVs = placeHolderNames })) }
201
202 mkTyFamInstEqn :: LHsType RdrName
203                -> LHsType RdrName
204                -> P (TyFamInstEqn RdrName)
205 mkTyFamInstEqn lhs rhs
206   = do { (tc, tparams) <- checkTyClHdr lhs
207        ; return (TyFamEqn { tfe_tycon = tc
208                           , tfe_pats  = mkHsWithBndrs tparams
209                           , tfe_rhs   = rhs }) }
210
211 mkDataFamInst :: SrcSpan
212          -> NewOrData
213          -> Maybe CType
214          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
215          -> Maybe (LHsKind RdrName)
216          -> [LConDecl RdrName]
217          -> Maybe [LHsType RdrName]
218          -> P (LInstDecl RdrName)
219 mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
220   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
221        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
222        ; return (L loc (DataFamInstD (
223                   DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams
224                                   , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
225
226 mkTyFamInst :: SrcSpan
227             -> LTyFamInstEqn RdrName
228             -> P (LInstDecl RdrName)
229 mkTyFamInst loc eqn
230   = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn  = eqn
231                                              , tfid_fvs  = placeHolderNames })))
232
233 mkFamDecl :: SrcSpan
234           -> FamilyInfo RdrName
235           -> LHsType RdrName   -- LHS
236           -> Maybe (LHsKind RdrName) -- Optional kind signature
237           -> P (LTyClDecl RdrName)
238 mkFamDecl loc info lhs ksig
239   = do { (tc, tparams) <- checkTyClHdr lhs
240        ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
241        ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc
242                                             , fdTyVars = tyvars, fdKindSig = ksig }))) }
243   where
244     equals_or_where = case info of
245                         DataFamily          -> empty
246                         OpenTypeFamily      -> empty
247                         ClosedTypeFamily {} -> whereDots
248
249 mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
250 -- If the user wrote
251 --      [pads| ... ]   then return a QuasiQuoteD
252 --      $(e)           then return a SpliceD
253 -- but if she wrote, say,
254 --      f x            then behave as if she'd written $(f x)
255 --                     ie a SpliceD
256 mkSpliceDecl lexpr@(L loc expr)
257   | HsQuasiQuoteE qq <- expr          = QuasiQuoteD qq
258   | HsSpliceE is_typed splice <- expr = ASSERT( not is_typed )
259                                         SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
260   | otherwise                         = SpliceD (SpliceDecl (L loc splice) ImplicitSplice)
261   where
262     splice = mkHsSplice lexpr
263
264 mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName)
265 mkTyLit l =
266   do allowed <- extension typeLiteralsEnabled
267      if allowed
268        then return (HsTyLit `fmap` l)
269        else parseErrorSDoc (getLoc l)
270               (text "Illegal literal in type (use DataKinds to enable):" <+>
271               ppr l)
272
273 mkRoleAnnotDecl :: SrcSpan
274                 -> Located RdrName                   -- type being annotated
275                 -> [Located (Maybe FastString)]      -- roles
276                 -> P (LRoleAnnotDecl RdrName)
277 mkRoleAnnotDecl loc tycon roles
278   = do { roles' <- mapM parse_role roles
279        ; return $ L loc $ RoleAnnotDecl tycon roles' }
280   where
281     role_data_type = dataTypeOf (undefined :: Role)
282     all_roles = map fromConstr $ dataTypeConstrs role_data_type
283     possible_roles = [(fsFromRole role, role) | role <- all_roles]
284
285     parse_role (L loc_role Nothing) = return $ L loc_role Nothing
286     parse_role (L loc_role (Just role))
287       = case lookup role possible_roles of
288           Just found_role -> return $ L loc_role $ Just found_role
289           Nothing         ->
290             let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
291             parseErrorSDoc loc_role
292               (text "Illegal role name" <+> quotes (ppr role) $$
293                suggestions nearby)
294
295     suggestions []   = empty
296     suggestions [r]  = text "Perhaps you meant" <+> quotes (ppr r)
297       -- will this last case ever happen??
298     suggestions list = hang (text "Perhaps you meant one of these:")
299                        2 (pprWithCommas (quotes . ppr) list)
300 \end{code}
301
302 %************************************************************************
303 %*                                                                      *
304 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
305 %*                                                                      *
306 %************************************************************************
307
308 Function definitions are restructured here. Each is assumed to be recursive
309 initially, and non recursive definitions are discovered by the dependency
310 analyser.
311
312
313 \begin{code}
314 --  | Groups together bindings for a single function
315 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
316 cvTopDecls decls = go (fromOL decls)
317   where
318     go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
319     go []                   = []
320     go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
321                             where (L l' b', ds') = getMonoBind (L l b) ds
322     go (d : ds)             = d : go ds
323
324 -- Declaration list may only contain value bindings and signatures.
325 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
326 cvBindGroup binding
327   = case cvBindsAndSigs binding of
328       (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) 
329          -> ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
330             ValBindsIn mbs sigs
331
332 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
333   -> (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName]
334           , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl])
335 -- Input decls contain just value bindings and signatures
336 -- and in case of class or instance declarations also
337 -- associated type declarations. They might also contain Haddock comments.
338 cvBindsAndSigs  fb = go (fromOL fb)
339   where
340     go []                  = (emptyBag, [], [], [], [], [])
341     go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs)
342                            where (bs, ss, ts, tfis, dfis, docs) = go ds
343     go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, tfis, dfis, docs)
344                            where (b', ds')    = getMonoBind (L l b) ds
345                                  (bs, ss, ts, tfis, dfis, docs) = go ds'
346     go (L l (TyClD (FamDecl t)) : ds) = (bs, ss, L l t : ts, tfis, dfis, docs)
347                            where (bs, ss, ts, tfis, dfis, docs) = go ds
348     go (L l (InstD (TyFamInstD { tfid_inst = tfi })) : ds) = (bs, ss, ts, L l tfi : tfis, dfis, docs)
349                            where (bs, ss, ts, tfis, dfis, docs) = go ds
350     go (L l (InstD (DataFamInstD { dfid_inst = dfi })) : ds) = (bs, ss, ts, tfis, L l dfi : dfis, docs)
351                            where (bs, ss, ts, tfis, dfis, docs) = go ds
352     go (L l (DocD d) : ds) =  (bs, ss, ts, tfis, dfis, (L l d) : docs)
353                            where (bs, ss, ts, tfis, dfis, docs) = go ds
354     go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
355
356 -----------------------------------------------------------------------------
357 -- Group function bindings into equation groups
358
359 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
360   -> (LHsBind RdrName, [LHsDecl RdrName])
361 -- Suppose      (b',ds') = getMonoBind b ds
362 --      ds is a list of parsed bindings
363 --      b is a MonoBinds that has just been read off the front
364
365 -- Then b' is the result of grouping more equations from ds that
366 -- belong with b into a single MonoBinds, and ds' is the depleted
367 -- list of parsed bindings.
368 --
369 -- All Haddock comments between equations inside the group are
370 -- discarded.
371 --
372 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
373
374 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
375                                fun_matches = MG { mg_alts = mtchs1 } })) binds
376   | has_args mtchs1
377   = go is_infix1 mtchs1 loc1 binds []
378   where
379     go is_infix mtchs loc
380        (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
381                                 fun_matches = MG { mg_alts = mtchs2 } })) : binds) _
382         | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
383                         (combineSrcSpans loc loc2) binds []
384     go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
385         = let doc_decls' = doc_decl : doc_decls
386           in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
387     go is_infix mtchs loc binds doc_decls
388         = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
389         -- Reverse the final matches, to get it back in the right order
390         -- Do the same thing with the trailing doc comments
391
392 getMonoBind bind binds = (bind, binds)
393
394 has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool
395 has_args []                           = panic "RdrHsSyn:has_args"
396 has_args ((L _ (Match args _ _)) : _) = not (null args)
397         -- Don't group together FunBinds if they have
398         -- no arguments.  This is necessary now that variable bindings
399         -- with no arguments are now treated as FunBinds rather
400         -- than pattern bindings (tests/rename/should_fail/rnfail002).
401 \end{code}
402
403 %************************************************************************
404 %*                                                                      *
405 \subsection[PrefixToHS-utils]{Utilities for conversion}
406 %*                                                                      *
407 %************************************************************************
408
409
410 \begin{code}
411 -----------------------------------------------------------------------------
412 -- splitCon
413
414 -- When parsing data declarations, we sometimes inadvertently parse
415 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
416 -- This function splits up the type application, adds any pending
417 -- arguments, and converts the type constructor back into a data constructor.
418
419 splitCon :: LHsType RdrName
420       -> P (Located RdrName, HsConDeclDetails RdrName)
421 -- This gets given a "type" that should look like
422 --      C Int Bool
423 -- or   C { x::Int, y::Bool }
424 -- and returns the pieces
425 splitCon ty
426  = split ty []
427  where
428    split (L _ (HsAppTy t u)) ts    = split t (u : ts)
429    split (L l (HsTyVar tc))  ts    = do data_con <- tyConToDataCon l tc
430                                         return (data_con, mk_rest ts)
431    split (L l (HsTupleTy _ [])) [] = return (L l (getRdrName unitDataCon), PrefixCon [])
432                                          -- See Note [Unit tuples] in HsTypes
433    split (L l _) _                 = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
434
435    mk_rest [L _ (HsRecTy flds)] = RecCon flds
436    mk_rest ts                   = PrefixCon ts
437
438 splitPatSyn :: LPat RdrName
439       -> P (Located RdrName, HsPatSynDetails (Located RdrName))
440 splitPatSyn (L _ (ParPat pat)) = splitPatSyn pat
441 splitPatSyn pat@(L loc (ConPatIn con details)) = do
442     details' <- case details of
443         PrefixCon pats     -> liftM PrefixPatSyn (mapM patVar pats)
444         InfixCon pat1 pat2 -> liftM2 InfixPatSyn (patVar pat1) (patVar pat2)
445         RecCon{}           -> recordPatSynErr loc pat
446     return (con, details')
447   where
448     patVar :: LPat RdrName -> P (Located RdrName)
449     patVar (L loc (VarPat v))   = return $ L loc v
450     patVar (L _   (ParPat pat)) = patVar pat
451     patVar (L loc pat)          = parseErrorSDoc loc $
452                                   text "Pattern synonym arguments must be variable names:" $$
453                                   ppr pat
454 splitPatSyn pat@(L loc _) = parseErrorSDoc loc $
455                             text "invalid pattern synonym declaration:" $$ ppr pat
456
457 recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
458 recordPatSynErr loc pat =
459     parseErrorSDoc loc $
460     text "record syntax not supported for pattern synonym declarations:" $$
461     ppr pat
462
463 toPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl RdrName)) -> P (MatchGroup RdrName (LHsExpr RdrName))
464 toPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
465     do { matches <- mapM fromDecl (fromOL decls)
466        ; return $ mkMatchGroup FromSource matches }
467   where
468     fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn (L _ name) details)) rhs _ _ _))) =
469         do { unless (name == patsyn_name) $
470                wrongNameBindingErr loc decl
471            ; match <- case details of
472                PrefixCon pats -> return $ Match pats Nothing rhs
473                InfixCon pat1 pat2 -> return $ Match [pat1, pat2] Nothing rhs
474                RecCon{} -> recordPatSynErr loc pat
475            ; return $ L loc match }
476     fromDecl (L loc decl) = extraDeclErr loc decl
477
478     extraDeclErr loc decl =
479         parseErrorSDoc loc $
480         text "pattern synonym 'where' clause must contain a single binding:" $$
481         ppr decl
482
483     wrongNameBindingErr loc decl =
484         parseErrorSDoc loc $
485         text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
486         quotes (ppr patsyn_name) $$ ppr decl
487
488 mkDeprecatedGadtRecordDecl :: SrcSpan
489                            -> Located RdrName
490                            -> [ConDeclField RdrName]
491                            -> LHsType RdrName
492                            ->  P (LConDecl  RdrName)
493 -- This one uses the deprecated syntax
494 --    C { x,y ::Int } :: T a b
495 -- We give it a RecCon details right away
496 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
497   = do { data_con <- tyConToDataCon con_loc con
498        ; return (L loc (ConDecl { con_old_rec  = True
499                                 , con_name     = data_con
500                                 , con_explicit = Implicit
501                                 , con_qvars    = mkHsQTvs []
502                                 , con_cxt      = noLoc []
503                                 , con_details  = RecCon flds
504                                 , con_res      = ResTyGADT res_ty
505                                 , con_doc      = Nothing })) }
506
507 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
508                 -> LHsContext RdrName -> HsConDeclDetails RdrName
509                 -> ConDecl RdrName
510
511 mkSimpleConDecl name qvars cxt details
512   = ConDecl { con_old_rec  = False
513             , con_name     = name
514             , con_explicit = Explicit
515             , con_qvars    = mkHsQTvs qvars
516             , con_cxt      = cxt
517             , con_details  = details
518             , con_res      = ResTyH98
519             , con_doc      = Nothing }
520
521 mkGadtDecl :: [Located RdrName]
522            -> LHsType RdrName     -- Always a HsForAllTy
523            -> [ConDecl RdrName]
524 -- We allow C,D :: ty
525 -- and expand it as if it had been
526 --    C :: ty; D :: ty
527 -- (Just like type signatures in general.)
528 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
529   = [mk_gadt_con name | name <- names]
530   where
531     (details, res_ty)           -- See Note [Sorting out the result type]
532       = case tau of
533           L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds,  res_ty)
534           _other                                    -> (PrefixCon [], tau)
535
536     mk_gadt_con name
537        = ConDecl { con_old_rec  = False
538                  , con_name     = name
539                  , con_explicit = imp
540                  , con_qvars    = qvars
541                  , con_cxt      = cxt
542                  , con_details  = details
543                  , con_res      = ResTyGADT res_ty
544                  , con_doc      = Nothing }
545 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
546
547 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
548 tyConToDataCon loc tc
549   | isTcOcc (rdrNameOcc tc)
550   = return (L loc (setRdrNameSpace tc srcDataName))
551   | otherwise
552   = parseErrorSDoc loc (msg $$ extra)
553   where
554     msg = text "Not a data constructor:" <+> quotes (ppr tc)
555     extra | tc == forall_tv_RDR
556           = text "Perhaps you intended to use ExistentialQuantification"
557           | otherwise = empty
558 \end{code}
559
560 Note [Sorting out the result type]
561 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
562 In a GADT declaration which is not a record, we put the whole constr
563 type into the ResTyGADT for now; the renamer will unravel it once it
564 has sorted out operator fixities. Consider for example
565      C :: a :*: b -> a :*: b -> a :+: b
566 Initially this type will parse as
567       a :*: (b -> (a :*: (b -> (a :+: b))))
568
569 so it's hard to split up the arguments until we've done the precedence
570 resolution (in the renamer) On the other hand, for a record
571         { x,y :: Int } -> a :*: b
572 there is no doubt.  AND we need to sort records out so that
573 we can bring x,y into scope.  So:
574    * For PrefixCon we keep all the args in the ResTyGADT
575    * For RecCon we do not
576
577 \begin{code}
578 checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
579 -- Same as checkTyVars, but in the P monad
580 checkTyVarsP pp_what equals_or_where tc tparms 
581   = eitherToP $ checkTyVars pp_what equals_or_where tc tparms 
582
583 eitherToP :: Either (SrcSpan, SDoc) a -> P a
584 -- Adapts the Either monad to the P monad
585 eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
586 eitherToP (Right thing)     = return thing
587 checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] 
588             -> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName)
589 -- Check whether the given list of type parameters are all type variables
590 -- (possibly with a kind signature)
591 -- We use the Either monad because it's also called (via mkATDefault) from
592 -- Convert.hs
593 checkTyVars pp_what equals_or_where tc tparms 
594   = do { tvs <- mapM chk tparms
595        ; return (mkHsQTvs tvs) }
596   where
597         
598         -- Check that the name space is correct!
599     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
600         | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
601     chk (L l (HsTyVar tv))
602         | isRdrTyVar tv    = return (L l (UserTyVar tv))
603     chk t@(L loc _)
604         = Left (loc, 
605                 vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
606                      , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
607                      , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form"))
608                      , nest 2 (pp_what <+> ppr tc 
609                                        <+> hsep (map text (takeList tparms allNameStrings))
610                                        <+> equals_or_where) ] ])
611
612 whereDots, equalsDots :: SDoc
613 -- Second argument to checkTyVars
614 whereDots  = ptext (sLit "where ...")
615 equalsDots = ptext (sLit "= ...")
616
617 checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
618 checkDatatypeContext Nothing = return ()
619 checkDatatypeContext (Just (L loc c))
620     = do allowed <- extension datatypeContextsEnabled
621          unless allowed $
622              parseErrorSDoc loc
623                  (text "Illegal datatype context (use DatatypeContexts):" <+>
624                   pprHsContext c)
625
626 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
627 checkRecordSyntax lr@(L loc r)
628     = do allowed <- extension traditionalRecordSyntaxEnabled
629          if allowed
630              then return lr
631              else parseErrorSDoc loc
632                       (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
633                        ppr r)
634
635 checkTyClHdr :: LHsType RdrName
636              -> P (Located RdrName,          -- the head symbol (type or class name)
637                    [LHsType RdrName])        -- parameters of head symbol
638 -- Well-formedness check and decomposition of type and class heads.
639 -- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
640 --              Int :*: Bool   into    (:*:, [Int, Bool])
641 -- returning the pieces
642 checkTyClHdr ty
643   = goL ty []
644   where
645     goL (L l ty) acc = go l ty acc
646
647     go l (HsTyVar tc) acc 
648         | isRdrTc tc          = return (L l tc, acc)
649     go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc
650         | isRdrTc tc         = return (ltc, t1:t2:acc)
651     go _ (HsParTy ty)    acc = goL ty acc
652     go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
653     go l (HsTupleTy _ []) [] = return (L l (getRdrName unitTyCon), [])
654                                    -- See Note [Unit tuples] in HsTypes
655     go l _               _   = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
656
657 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
658 checkContext (L l orig_t)
659   = check orig_t
660  where
661   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
662     = return (L l ts)           -- Ditto ()
663
664   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
665     = check (unLoc ty)
666
667   check _
668     = return (L l [L l orig_t])
669
670 -- -------------------------------------------------------------------------
671 -- Checking Patterns.
672
673 -- We parse patterns as expressions and check for valid patterns below,
674 -- converting the expression into a pattern at the same time.
675
676 checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
677 checkPattern msg e = checkLPat msg e
678
679 checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName]
680 checkPatterns msg es = mapM (checkPattern msg) es
681
682 checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
683 checkLPat msg e@(L l _) = checkPat msg l e []
684
685 checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
686          -> P (LPat RdrName)
687 checkPat _ loc (L l (HsVar c)) args
688   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
689 checkPat msg loc e args     -- OK to let this happen even if bang-patterns
690                         -- are not enabled, because there is no valid
691                         -- non-bang-pattern parse of (C ! e)
692   | Just (e', args') <- splitBang e
693   = do  { args'' <- checkPatterns msg args'
694         ; checkPat msg loc e' (args'' ++ args) }
695 checkPat msg loc (L _ (HsApp f e)) args
696   = do p <- checkLPat msg e
697        checkPat msg loc f (p : args)
698 checkPat msg loc (L _ e) []
699   = do p <- checkAPat msg loc e
700        return (L loc p)
701 checkPat msg loc e _
702   = patFail msg loc (unLoc e)
703
704 checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
705 checkAPat msg loc e0 = do
706  pState <- getPState
707  let dynflags = dflags pState
708  case e0 of
709    EWildPat -> return (WildPat placeHolderType)
710    HsVar x  -> return (VarPat x)
711    HsLit l  -> return (LitPat l)
712
713    -- Overloaded numeric patterns (e.g. f 0 x = x)
714    -- Negation is recorded separately, so that the literal is zero or +ve
715    -- NB. Negative *primitive* literals are already handled by the lexer
716    HsOverLit pos_lit          -> return (mkNPat pos_lit Nothing)
717    NegApp (L _ (HsOverLit pos_lit)) _
718                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
719
720    SectionR (L _ (HsVar bang)) e        -- (! x)
721         | bang == bang_RDR
722         -> do { bang_on <- extension bangPatEnabled
723               ; if bang_on then checkLPat msg e >>= (return . BangPat)
724                 else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
725
726    ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)
727    EAsPat n e         -> checkLPat msg e >>= (return . AsPat n)
728    -- view pattern is well-formed if the pattern is
729    EViewPat expr patE -> checkLPat msg patE >>=
730                             (return . (\p -> ViewPat expr p placeHolderType))
731    ExprWithTySig e t  -> do e <- checkLPat msg e
732                             -- Pattern signatures are parsed as sigtypes,
733                             -- but they aren't explicit forall points.  Hence
734                             -- we have to remove the implicit forall here.
735                             let t' = case t of
736                                        L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
737                                        other -> other
738                             return (SigPatIn e (mkHsWithBndrs t'))
739
740    -- n+k patterns
741    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
742          (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
743                       | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
744                       -> return (mkNPlusKPat (L nloc n) lit)
745
746    OpApp l op _fix r  -> do l <- checkLPat msg l
747                             r <- checkLPat msg r
748                             case op of
749                                L cl (HsVar c) | isDataOcc (rdrNameOcc c)
750                                       -> return (ConPatIn (L cl c) (InfixCon l r))
751                                _ -> patFail msg loc e0
752
753    HsPar e            -> checkLPat msg e >>= (return . ParPat)
754    ExplicitList _ _ es  -> do ps <- mapM (checkLPat msg) es
755                               return (ListPat ps placeHolderType Nothing)
756    ExplicitPArr _ es  -> do ps <- mapM (checkLPat msg) es
757                             return (PArrPat ps placeHolderType)
758
759    ExplicitTuple es b
760      | all tupArgPresent es  -> do ps <- mapM (checkLPat msg) [e | Present e <- es]
761                                    return (TuplePat ps b [])
762      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
763
764    RecordCon c _ (HsRecFields fs dd)
765                         -> do fs <- mapM (checkPatField msg) fs
766                               return (ConPatIn c (RecCon (HsRecFields fs dd)))
767    HsSpliceE is_typed s | not is_typed 
768                         -> return (SplicePat s)
769    HsQuasiQuoteE q      -> return (QuasiQuotePat q)
770    _                    -> patFail msg loc e0
771
772 placeHolderPunRhs :: LHsExpr RdrName
773 -- The RHS of a punned record field will be filled in by the renamer
774 -- It's better not to make it an error, in case we want to print it when debugging
775 placeHolderPunRhs = noLoc (HsVar pun_RDR)
776
777 plus_RDR, bang_RDR, pun_RDR :: RdrName
778 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
779 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
780 pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
781
782 checkPatField :: SDoc -> HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
783 checkPatField msg fld = do p <- checkLPat msg (hsRecFieldArg fld)
784                            return (fld { hsRecFieldArg = p })
785
786 patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a
787 patFail msg loc e = parseErrorSDoc loc err
788     where err = text "Parse error in pattern:" <+> ppr e
789              $$ msg
790
791
792 ---------------------------------------------------------------------------
793 -- Check Equation Syntax
794
795 checkValDef :: SDoc
796             -> LHsExpr RdrName
797             -> Maybe (LHsType RdrName)
798             -> Located (GRHSs RdrName (LHsExpr RdrName))
799             -> P (HsBind RdrName)
800
801 checkValDef msg lhs (Just sig) grhss
802         -- x :: ty = rhs  parses as a *pattern* binding
803   = checkPatBind msg (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
804
805 checkValDef msg lhs opt_sig grhss
806   = do  { mb_fun <- isFunLhs lhs
807         ; case mb_fun of
808             Just (fun, is_infix, pats) -> checkFunBind msg (getLoc lhs)
809                                                 fun is_infix pats opt_sig grhss
810             Nothing -> checkPatBind msg lhs grhss }
811
812 checkFunBind :: SDoc
813              -> SrcSpan
814              -> Located RdrName
815              -> Bool
816              -> [LHsExpr RdrName]
817              -> Maybe (LHsType RdrName)
818              -> Located (GRHSs RdrName (LHsExpr RdrName))
819              -> P (HsBind RdrName)
820 checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
821   = do  ps <- checkPatterns msg pats
822         let match_span = combineSrcSpans lhs_loc rhs_span
823         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
824         -- The span of the match covers the entire equation.
825         -- That isn't quite right, but it'll do for now.
826
827 makeFunBind :: Located RdrName -> Bool -> [LMatch RdrName (LHsExpr RdrName)]
828             -> HsBind RdrName
829 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
830 makeFunBind fn is_infix ms
831   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup FromSource ms,
832               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
833
834 checkPatBind :: SDoc
835              -> LHsExpr RdrName
836              -> Located (GRHSs RdrName (LHsExpr RdrName))
837              -> P (HsBind RdrName)
838 checkPatBind msg lhs (L _ grhss)
839   = do  { lhs <- checkPattern msg lhs
840         ; return (PatBind lhs grhss placeHolderType placeHolderNames
841                     (Nothing,[])) }
842
843 checkValSig
844         :: LHsExpr RdrName
845         -> LHsType RdrName
846         -> P (Sig RdrName)
847 checkValSig (L l (HsVar v)) ty
848   | isUnqual v && not (isDataOcc (rdrNameOcc v))
849   = return (TypeSig [L l v] ty)
850 checkValSig lhs@(L l _) ty
851   = parseErrorSDoc l ((text "Invalid type signature:" <+>
852                        ppr lhs <+> text "::" <+> ppr ty)
853                    $$ text hint)
854   where
855     hint = if foreign_RDR `looks_like` lhs
856            then "Perhaps you meant to use ForeignFunctionInterface?"
857            else if default_RDR `looks_like` lhs
858                 then "Perhaps you meant to use DefaultSignatures?"
859                 else "Should be of form <variable> :: <type>"
860     -- A common error is to forget the ForeignFunctionInterface flag
861     -- so check for that, and suggest.  cf Trac #3805
862     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
863     looks_like s (L _ (HsVar v))     = v == s
864     looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
865     looks_like _ _                   = False
866
867     foreign_RDR = mkUnqual varName (fsLit "foreign")
868     default_RDR = mkUnqual varName (fsLit "default")
869
870 checkDoAndIfThenElse :: LHsExpr RdrName
871                      -> Bool
872                      -> LHsExpr RdrName
873                      -> Bool
874                      -> LHsExpr RdrName
875                      -> P ()
876 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
877  | semiThen || semiElse
878     = do pState <- getPState
879          unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do
880              parseErrorSDoc (combineLocs guardExpr elseExpr)
881                             (text "Unexpected semi-colons in conditional:"
882                           $$ nest 4 expr
883                           $$ text "Perhaps you meant to use DoAndIfThenElse?")
884  | otherwise            = return ()
885     where pprOptSemi True  = semi
886           pprOptSemi False = empty
887           expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>
888                  text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>
889                  text "else" <+> ppr elseExpr
890 \end{code}
891
892
893 \begin{code}
894         -- The parser left-associates, so there should
895         -- not be any OpApps inside the e's
896 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
897 -- Splits (f ! g a b) into (f, [(! g), a, b])
898 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
899   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
900   where
901     (arg1,argns) = split_bang r_arg []
902     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
903     split_bang e                 es = (e,es)
904 splitBang _ = Nothing
905
906 isFunLhs :: LHsExpr RdrName
907          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
908 -- A variable binding is parsed as a FunBind.
909 -- Just (fun, is_infix, arg_pats) if e is a function LHS
910 --
911 -- The whole LHS is parsed as a single expression.
912 -- Any infix operators on the LHS will parse left-associatively
913 -- E.g.         f !x y !z
914 --      will parse (rather strangely) as
915 --              (f ! x y) ! z
916 --      It's up to isFunLhs to sort out the mess
917 --
918 -- a .!. !b
919
920 isFunLhs e = go e []
921  where
922    go (L loc (HsVar f)) es
923         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
924    go (L _ (HsApp f e)) es       = go f (e:es)
925    go (L _ (HsPar e))   es@(_:_) = go e es
926
927         -- For infix function defns, there should be only one infix *function*
928         -- (though there may be infix *datacons* involved too).  So we don't
929         -- need fixity info to figure out which function is being defined.
930         --      a `K1` b `op` c `K2` d
931         -- must parse as
932         --      (a `K1` b) `op` (c `K2` d)
933         -- The renamer checks later that the precedences would yield such a parse.
934         --
935         -- There is a complication to deal with bang patterns.
936         --
937         -- ToDo: what about this?
938         --              x + 1 `op` y = ...
939
940    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
941         | Just (e',es') <- splitBang e
942         = do { bang_on <- extension bangPatEnabled
943              ; if bang_on then go e' (es' ++ es)
944                else return (Just (L loc' op, True, (l:r:es))) }
945                 -- No bangs; behave just like the next case
946         | not (isRdrDataCon op)         -- We have found the function!
947         = return (Just (L loc' op, True, (l:r:es)))
948         | otherwise                     -- Infix data con; keep going
949         = do { mb_l <- go l es
950              ; case mb_l of
951                  Just (op', True, j : k : es')
952                     -> return (Just (op', True, j : op_app : es'))
953                     where
954                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
955                  _ -> return Nothing }
956    go _ _ = return Nothing
957
958
959 ---------------------------------------------------------------------------
960 -- Check for monad comprehensions
961 --
962 -- If the flag MonadComprehensions is set, return a `MonadComp' context,
963 -- otherwise use the usual `ListComp' context
964
965 checkMonadComp :: P (HsStmtContext Name)
966 checkMonadComp = do
967     pState <- getPState
968     return $ if xopt Opt_MonadComprehensions (dflags pState)
969                 then MonadComp
970                 else ListComp
971
972 -- -------------------------------------------------------------------------
973 -- Checking arrow syntax.
974
975 -- We parse arrow syntax as expressions and check for valid syntax below,
976 -- converting the expression into a pattern at the same time.
977
978 checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName)
979 checkCommand lc = locMap checkCmd lc
980
981 locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
982 locMap f (L l a) = f l a >>= (\b -> return $ L l b)
983
984 checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName)
985 checkCmd _ (HsArrApp e1 e2 ptt haat b) = 
986     return $ HsCmdArrApp e1 e2 ptt haat b
987 checkCmd _ (HsArrForm e mf args) = 
988     return $ HsCmdArrForm e mf args
989 checkCmd _ (HsApp e1 e2) = 
990     checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)
991 checkCmd _ (HsLam mg) = 
992     checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg')
993 checkCmd _ (HsPar e) = 
994     checkCommand e >>= (\c -> return $ HsCmdPar c)
995 checkCmd _ (HsCase e mg) = 
996     checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')
997 checkCmd _ (HsIf cf ep et ee) = do
998     pt <- checkCommand et
999     pe <- checkCommand ee
1000     return $ HsCmdIf cf ep pt pe
1001 checkCmd _ (HsLet lb e) = 
1002     checkCommand e >>= (\c -> return $ HsCmdLet lb c)
1003 checkCmd _ (HsDo DoExpr stmts ty) = 
1004     mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo ss ty)
1005
1006 checkCmd _ (OpApp eLeft op _fixity eRight) = do
1007     -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
1008     c1 <- checkCommand eLeft
1009     c2 <- checkCommand eRight
1010     let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []
1011         arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []
1012     return $ HsCmdArrForm op Nothing [arg1, arg2]
1013
1014 checkCmd l e = cmdFail l e
1015
1016 checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName)
1017 checkCmdLStmt = locMap checkCmdStmt
1018
1019 checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName)
1020 checkCmdStmt _ (LastStmt e r) = 
1021     checkCommand e >>= (\c -> return $ LastStmt c r)
1022 checkCmdStmt _ (BindStmt pat e b f) = 
1023     checkCommand e >>= (\c -> return $ BindStmt pat c b f)
1024 checkCmdStmt _ (BodyStmt e t g ty) = 
1025     checkCommand e >>= (\c -> return $ BodyStmt c t g ty)
1026 checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds
1027 checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
1028     ss <- mapM checkCmdLStmt stmts
1029     return $ stmt { recS_stmts = ss }
1030 checkCmdStmt l stmt = cmdStmtFail l stmt
1031
1032 checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName))
1033 checkCmdMatchGroup mg@(MG { mg_alts = ms }) = do
1034     ms' <- mapM (locMap $ const convert) ms
1035     return $ mg { mg_alts = ms' }
1036     where convert (Match pat mty grhss) = do
1037             grhss' <- checkCmdGRHSs grhss
1038             return $ Match pat mty grhss'
1039
1040 checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName))
1041 checkCmdGRHSs (GRHSs grhss binds) = do
1042     grhss' <- mapM checkCmdGRHS grhss
1043     return $ GRHSs grhss' binds
1044
1045 checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName))
1046 checkCmdGRHS = locMap $ const convert
1047   where 
1048     convert (GRHS stmts e) = do
1049         c <- checkCommand e
1050 --        cmdStmts <- mapM checkCmdLStmt stmts
1051         return $ GRHS {- cmdStmts -} stmts c
1052
1053
1054 cmdFail :: SrcSpan -> HsExpr RdrName -> P a
1055 cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
1056 cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a
1057 cmdStmtFail loc e = parseErrorSDoc loc 
1058                     (text "Parse error in command statement:" <+> ppr e)
1059
1060 ---------------------------------------------------------------------------
1061 -- Miscellaneous utilities
1062
1063 checkPrecP :: Located Int -> P Int
1064 checkPrecP (L l i)
1065  | 0 <= i && i <= maxPrecedence = return i
1066  | otherwise
1067     = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
1068
1069 mkRecConstrOrUpdate
1070         :: LHsExpr RdrName
1071         -> SrcSpan
1072         -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
1073         -> P (HsExpr RdrName)
1074
1075 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) 
1076   | isRdrDataCon c
1077   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
1078 mkRecConstrOrUpdate exp _ (fs,dd)
1079   = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
1080
1081 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
1082 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
1083 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
1084
1085 mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
1086 -- The (Maybe Activation) is because the user can omit 
1087 -- the activation spec (and usually does)
1088 mkInlinePragma (inl, match_info) mb_act
1089   = InlinePragma { inl_inline = inl
1090                  , inl_sat    = Nothing
1091                  , inl_act    = act
1092                  , inl_rule   = match_info }
1093   where
1094     act = case mb_act of
1095             Just act -> act
1096             Nothing  -> -- No phase specified
1097                         case inl of
1098                           NoInline -> NeverActive
1099                           _other   -> AlwaysActive
1100
1101 -----------------------------------------------------------------------------
1102 -- utilities for foreign declarations
1103
1104 -- construct a foreign import declaration
1105 --
1106 mkImport :: CCallConv
1107          -> Safety
1108          -> (Located FastString, Located RdrName, LHsType RdrName)
1109          -> P (HsDecl RdrName)
1110 mkImport cconv safety (L loc entity, v, ty)
1111   | cconv == PrimCallConv                      = do
1112   let funcTarget = CFunction (StaticTarget entity Nothing True)
1113       importSpec = CImport PrimCallConv safety Nothing funcTarget
1114   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
1115   | cconv == JavaScriptCallConv = do
1116   let funcTarget = CFunction (StaticTarget entity Nothing True)
1117       importSpec = CImport JavaScriptCallConv safety Nothing funcTarget
1118   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
1119   | otherwise = do
1120     case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
1121       Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
1122       Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
1123
1124 -- the string "foo" is ambigous: either a header or a C identifier.  The
1125 -- C identifier case comes first in the alternatives below, so we pick
1126 -- that one.
1127 parseCImport :: CCallConv -> Safety -> FastString -> String
1128              -> Maybe ForeignImport
1129 parseCImport cconv safety nm str =
1130  listToMaybe $ map fst $ filter (null.snd) $
1131      readP_to_S parse str
1132  where
1133    parse = do
1134        skipSpaces
1135        r <- choice [
1136           string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
1137           string "wrapper" >> return (mk Nothing CWrapper),
1138           do optional (token "static" >> skipSpaces)
1139              ((mk Nothing <$> cimp nm) +++
1140               (do h <- munch1 hdr_char
1141                   skipSpaces
1142                   mk (Just (Header (mkFastString h))) <$> cimp nm))
1143          ]
1144        skipSpaces
1145        return r
1146
1147    token str = do _ <- string str
1148                   toks <- look
1149                   case toks of
1150                       c : _
1151                        | id_char c -> pfail
1152                       _            -> return ()
1153
1154    mk = CImport cconv safety
1155
1156    hdr_char c = not (isSpace c) -- header files are filenames, which can contain
1157                                 -- pretty much any char (depending on the platform),
1158                                 -- so just accept any non-space character
1159    id_first_char c = isAlpha    c || c == '_'
1160    id_char       c = isAlphaNum c || c == '_'
1161
1162    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1163              +++ (do isFun <- case cconv of
1164                               CApiConv ->
1165                                   option True
1166                                          (do token "value"
1167                                              skipSpaces
1168                                              return False)
1169                               _ -> return True
1170                      cid' <- cid
1171                      return (CFunction (StaticTarget cid' Nothing isFun)))
1172           where
1173             cid = return nm +++
1174                   (do c  <- satisfy id_first_char
1175                       cs <-  many (satisfy id_char)
1176                       return (mkFastString (c:cs)))
1177
1178
1179 -- construct a foreign export declaration
1180 --
1181 mkExport :: CCallConv
1182          -> (Located FastString, Located RdrName, LHsType RdrName)
1183          -> P (HsDecl RdrName)
1184 mkExport cconv (L _ entity, v, ty) = return $
1185   ForD (ForeignExport v ty noForeignExportCoercionYet (CExport (CExportStatic entity' cconv)))
1186   where
1187     entity' | nullFS entity = mkExtName (unLoc v)
1188             | otherwise     = entity
1189
1190 -- Supplying the ext_name in a foreign decl is optional; if it
1191 -- isn't there, the Haskell name is assumed. Note that no transformation
1192 -- of the Haskell name is then performed, so if you foreign export (++),
1193 -- it's external name will be "++". Too bad; it's important because we don't
1194 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1195 --
1196 mkExtName :: RdrName -> CLabelString
1197 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1198 \end{code}
1199
1200 --------------------------------------------------------------------------------
1201 -- Help with module system imports/exports
1202
1203 \begin{code}
1204 data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [ RdrName ]
1205
1206 mkModuleImpExp :: RdrName -> ImpExpSubSpec -> IE RdrName
1207 mkModuleImpExp name subs =
1208   case subs of
1209     ImpExpAbs 
1210       | isVarNameSpace (rdrNameSpace name) -> IEVar       name
1211       | otherwise                          -> IEThingAbs  nameT
1212     ImpExpAll                              -> IEThingAll  nameT
1213     ImpExpList xs                          -> IEThingWith nameT xs
1214
1215   where
1216     nameT = setRdrNameSpace name tcClsName
1217
1218 mkTypeImpExp :: Located RdrName -> P (Located RdrName)
1219 mkTypeImpExp name =
1220   do allowed <- extension explicitNamespacesEnabled
1221      if allowed
1222        then return (fmap (`setRdrNameSpace` tcClsName) name)
1223        else parseErrorSDoc (getLoc name)
1224               (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
1225 \end{code}
1226
1227 -----------------------------------------------------------------------------
1228 -- Misc utils
1229
1230 \begin{code}
1231 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1232 parseErrorSDoc span s = failSpanMsgP span s
1233 \end{code}