RdrHsSyn.lhs 38.1 KB
Newer Older
1
%
2
% (c) The University of Glasgow, 1996-2003
3

4
Functions over HsSyn specialised to RdrName.
5 6 7

\begin{code}
module RdrHsSyn (
8 9
	extractHsTyRdrTyVars, 
	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 30
	mkSimpleConDecl, 
	mkDeprecatedGadtRecordDecl,
31

32 33
	-- Bunch of functions in the parser monad for 
	-- checking and constructing values
34 35 36
	checkPrecP, 	      -- Int -> P Int
	checkContext,	      -- HsType -> P HsContext
	checkPred,	      -- HsType -> P HsPred
37
	checkTyVars,          -- [LHsType RdrName] -> P ()
38
	checkKindSigs,	      -- [LTyClDecl RdrName] -> P ()
39 40
	checkInstType,	      -- HsType -> P HsType
	checkPattern,	      -- HsExp -> P HsPat
41
	bang_RDR,
42 43 44 45 46
	checkPatterns,	      -- SrcLoc -> [HsExp] -> P [HsPat]
	checkDo,	      -- [Stmt] -> P [Stmt]
	checkMDo,	      -- [Stmt] -> P [Stmt]
	checkValDef,	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
	checkValSig,	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
47 48
	parseError,	    
	parseErrorSDoc,	    
49 50
    ) where

51
import HsSyn		-- Lots of it
52 53
import Class            ( FunDep )
import TypeRep          ( Kind )
54
import RdrName		( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
55
			  isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
56 57
import BasicTypes	( maxPrecedence, Activation(..), RuleMatchInfo,
                          InlinePragma(..) )
58
import Lexer
59
import TysWiredIn	( unitTyCon ) 
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 69
import Outputable
import FastString
70
import Maybes
71

72 73 74
import Control.Applicative ((<$>))       
import Text.ParserCombinators.ReadP as ReadP
import Data.List        ( nubBy )
Ian Lynagh's avatar
Ian Lynagh committed
75
import Data.Char
76 77

#include "HsVersions.h"
78 79
\end{code}

80 81 82 83

%************************************************************************
%*									*
\subsection{A few functions over HsSyn at RdrName}
84
%*                                                                    *
85 86
%************************************************************************

87
extractHsTyRdrNames finds the free variables of a HsType
88 89 90
It's used when making the for-alls explicit.

\begin{code}
91 92
extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
93

94 95 96
extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])

97
extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
98 99
-- This one takes the context and tau-part of a 
-- sigma type and returns their free type variables
100 101 102
extractHsRhoRdrTyVars ctxt ty 
 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])

103
extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
104
extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
105

106
extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
107
extract_pred (HsClassP _   tys) acc = extract_ltys tys acc
108
extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
109
extract_pred (HsIParam _   ty ) acc = extract_lty ty acc
110

111 112 113
extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
extract_ltys tys acc = foldr extract_lty acc tys

114
extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
115 116 117 118
extract_lty (L loc ty) acc 
  = case ty of
      HsTyVar tv 	        -> extract_tv loc tv acc
      HsBangTy _ ty            	-> extract_lty ty acc
119
      HsRecTy flds            	-> foldr (extract_lty . cd_fld_type) acc flds
120 121 122
      HsAppTy ty1 ty2          	-> extract_lty ty1 (extract_lty ty2 acc)
      HsListTy ty              	-> extract_lty ty acc
      HsPArrTy ty              	-> extract_lty ty acc
123
      HsTupleTy _ tys          	-> extract_ltys tys acc
124 125 126 127
      HsFunTy ty1 ty2          	-> extract_lty ty1 (extract_lty ty2 acc)
      HsPredTy p		-> extract_pred p acc
      HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
      HsParTy ty               	-> extract_lty ty acc
128
      HsNumTy _                 -> acc
129
      HsQuasiQuoteTy {}	        -> acc  -- Quasi quotes mention no type variables
130
      HsSpliceTy {}           	-> acc	-- Type splices mention no type variables
131 132 133
      HsKindSig ty _            -> extract_lty ty acc
      HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
      HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
134 135 136
					   extract_lctxt cx (extract_lty ty []))
				where
				   locals = hsLTyVarNames tvs
137
      HsDocTy ty _              -> extract_lty ty acc
138 139 140 141

extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
		      | otherwise     = acc
142

143
extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
144 145 146
-- Get the type variables out of the type patterns in a bunch of
-- possibly-generic bindings in a class declaration
extractGenericPatTyVars binds
147
  = nubBy eqLocated (foldrBag get [] binds)
148
  where
149
    get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
150
    get _                                                 acc = acc
151

152
    get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
153
    get_m _                                        acc = acc
154 155
\end{code}

156 157 158 159 160 161 162

%************************************************************************
%*									*
\subsection{Construction functions for Rdr stuff}
%*                                                                    *
%************************************************************************

163
mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
164 165 166
by deriving them from the name of the class.  We fill in the names for the
tycon and datacon corresponding to the class, by deriving them from the
name of the class itself.  This saves recording the names in the interface
167 168
file (which would be equally good).

169
Similarly for mkConDecl, mkClassOpSig and default-method names.
170 171

	*** See "THE NAMING STORY" in HsDecls ****
172
  
173
\begin{code}
174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192
mkClassDecl :: SrcSpan
            -> Located (LHsContext RdrName, LHsType RdrName) 
            -> Located [Located (FunDep RdrName)]
            -> Located (OrdList (LHsDecl RdrName))
	    -> P (LTyClDecl RdrName)

mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
  = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
       ; (cls, tparams) <- checkTyClHdr tycl_hdr
       ; tyvars <- checkTyVars tparams      -- Only type vars allowed
       ; checkKindSigs ats
       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
		             	    tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
			     	    tcdATs   = ats, tcdDocs  = docs })) }

mkTyData :: SrcSpan
         -> NewOrData
	 -> Bool		-- True <=> data family instance
         -> Located (LHsContext RdrName, LHsType RdrName)
193
         -> Maybe Kind
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224
         -> [LConDecl RdrName]
         -> Maybe [LHsType RdrName]
         -> P (LTyClDecl RdrName)
mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
  = do { (tc, tparams) <- checkTyClHdr tycl_hdr

       ; (tyvars, typats) <- checkTParams is_family tparams
       ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
	                  	 tcdTyVars = tyvars, tcdTyPats = typats, 
                                 tcdCons = data_cons, 
	                  	 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }

mkTySynonym :: SrcSpan 
            -> Bool	        -- True <=> type family instances
            -> LHsType RdrName  -- LHS
            -> LHsType RdrName	-- RHS
            -> P (LTyClDecl RdrName)
mkTySynonym loc is_family lhs rhs
  = do { (tc, tparams) <- checkTyClHdr lhs
       ; (tyvars, typats) <- checkTParams is_family tparams
       ; return (L loc (TySynonym tc tyvars typats rhs)) }

mkTyFamily :: SrcSpan
           -> FamilyFlavour
	   -> LHsType RdrName   -- LHS
	   -> Maybe Kind        -- Optional kind signature
           -> P (LTyClDecl RdrName)
mkTyFamily loc flavour lhs ksig
  = do { (tc, tparams) <- checkTyClHdr lhs
       ; tyvars <- checkTyVars tparams
       ; return (L loc (TyFamily flavour tc tyvars ksig)) }
225 226 227

mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
-- If the user wrote
228 229 230 231 232 233
--      [pads| ... ]   then return a QuasiQuoteD
--	$(e)           then return a SpliceD
-- but if she wrote, say,
--      f x            then behave as if she'd written $(f x)
--		       ie a SpliceD
mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq
234 235
mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr       Explicit)
mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr Implicit)
236
\end{code}
237

238
%************************************************************************
239
%*									*
240
\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
241 242 243 244 245 246 247 248
%*									*
%************************************************************************

Function definitions are restructured here. Each is assumed to be recursive
initially, and non recursive definitions are discovered by the dependency
analyser.


249
\begin{code}
250
--  | Groups together bindings for a single function
251 252
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
253
  where
254 255 256 257 258 259
    go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
    go [] 		    = []
    go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
			    where (L l' b', ds') = getMonoBind (L l b) ds
    go (d : ds)   	    = d : go ds

260
-- Declaration list may only contain value bindings and signatures.
261
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
262
cvBindGroup binding
263
  = case cvBindsAndSigs binding of
264 265
      (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
      	    	  	         ValBindsIn mbs sigs
266

267
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
268
  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
269
-- Input decls contain just value bindings and signatures
270
-- and in case of class or instance declarations also
271
-- associated type declarations. They might also contain Haddock comments.
272
cvBindsAndSigs  fb = go (fromOL fb)
273
  where
274
    go [] 		   = (emptyBag, [], [], [])
275
    go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
276
			   where (bs, ss, ts, docs) = go ds
277
    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
278 279
			   where (b', ds')    = getMonoBind (L l b) ds
				 (bs, ss, ts, docs) = go ds'
280
    go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
281 282 283 284
			   where (bs, ss, ts, docs) = go ds
    go (L l (DocD d) : ds) =  (bs, ss, ts, (L l d) : docs)
			   where (bs, ss, ts, docs) = go ds
    go (L _ d : _)        = pprPanic "cvBindsAndSigs" (ppr d)
285 286 287 288

-----------------------------------------------------------------------------
-- Group function bindings into equation groups

289 290
getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
  -> (LHsBind RdrName, [LHsDecl RdrName])
291
-- Suppose 	(b',ds') = getMonoBind b ds
292
-- 	ds is a list of parsed bindings
293 294 295 296 297 298
--	b is a MonoBinds that has just been read off the front

-- Then b' is the result of grouping more equations from ds that
-- belong with b into a single MonoBinds, and ds' is the depleted
-- list of parsed bindings.
--
299 300 301
-- All Haddock comments between equations inside the group are 
-- discarded.
--
302 303
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

304 305
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
                               fun_matches = MatchGroup mtchs1 _ })) binds
306
  | has_args mtchs1
307
  = go is_infix1 mtchs1 loc1 binds []
308
  where
309 310
    go is_infix mtchs loc 
       (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
311
			        fun_matches = MatchGroup mtchs2 _ })) : binds) _
312
	| f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) 
313 314 315 316 317 318
		        (combineSrcSpans loc loc2) binds []
    go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls 
	= let doc_decls' = doc_decl : doc_decls  
          in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
    go is_infix mtchs loc binds doc_decls
	= (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
319
	-- Reverse the final matches, to get it back in the right order
320
        -- Do the same thing with the trailing doc comments
321

322 323
getMonoBind bind binds = (bind, binds)

324
has_args :: [LMatch RdrName] -> Bool
325
has_args [] 	    	     	      = panic "RdrHsSyn:has_args"
326 327
has_args ((L _ (Match args _ _)) : _) = not (null args)
	-- Don't group together FunBinds if they have
328
	-- no arguments.  This is necessary now that variable bindings
329
	-- with no arguments are now treated as FunBinds rather
330
	-- than pattern bindings (tests/rename/should_fail/rnfail002).
331 332 333 334 335 336 337 338 339 340
\end{code}

%************************************************************************
%*									*
\subsection[PrefixToHS-utils]{Utilities for conversion}
%*									*
%************************************************************************


\begin{code}
341
-----------------------------------------------------------------------------
342
-- splitCon
343 344 345 346 347 348

-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.

349 350 351 352 353 354 355 356
splitCon :: LHsType RdrName
      -> P (Located RdrName, HsConDeclDetails RdrName)
-- This gets given a "type" that should look like
--      C Int Bool
-- or   C { x::Int, y::Bool }
-- and returns the pieces
splitCon ty
 = split ty []
357
 where
358
   split (L _ (HsAppTy t u)) ts = split t (u : ts)
359
   split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397
 				     return (data_con, mk_rest ts)
   split (L l _) _ 	        = parseError l "parse error in data/newtype declaration"

   mk_rest [L _ (HsRecTy flds)] = RecCon flds
   mk_rest ts                   = PrefixCon ts

mkDeprecatedGadtRecordDecl :: SrcSpan 
		     	   -> Located RdrName
		     	   -> [ConDeclField RdrName]
			   -> LHsType RdrName
		     	   ->  P (LConDecl  RdrName)
-- This one uses the deprecated syntax
--    C { x,y ::Int } :: T a b
-- We give it a RecCon details right away
mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
  = do { data_con <- tyConToDataCon con_loc con
       ; return (L loc (ConDecl { con_old_rec  = True
                                , con_name     = data_con
	    	 		, con_explicit = Implicit
	    	 		, con_qvars    = []
	    	 		, con_cxt      = noLoc []
	    	 		, con_details  = RecCon flds
	    	 		, con_res      = ResTyGADT res_ty
            	 		, con_doc      = Nothing })) }

mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
		-> LHsContext RdrName -> HsConDeclDetails RdrName
		-> ConDecl RdrName

mkSimpleConDecl name qvars cxt details
  = ConDecl { con_old_rec  = False
            , con_name     = name
	    , con_explicit = Explicit
	    , con_qvars    = qvars
	    , con_cxt      = cxt
	    , con_details  = details
	    , con_res      = ResTyH98
            , con_doc      = Nothing }
398

399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423
mkGadtDecl :: [Located RdrName]
           -> LHsType RdrName     -- Always a HsForAllTy
           -> [ConDecl RdrName]
-- We allow C,D :: ty
-- and expand it as if it had been 
--    C :: ty; D :: ty
-- (Just like type signatures in general.)
mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
  = [mk_gadt_con name | name <- names]
  where
    (details, res_ty)		-- See Note [Sorting out the result type]
      = case tau of
    	  L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds,  res_ty)
	  _other                                    -> (PrefixCon [], tau)

    mk_gadt_con name
       = ConDecl { con_old_rec  = False
                 , con_name     = name
	    	 , con_explicit = imp
	    	 , con_qvars    = qvars
	    	 , con_cxt      = cxt
	    	 , con_details  = details
	    	 , con_res      = ResTyGADT res_ty
            	 , con_doc      = Nothing }
mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
424 425 426

tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
427
  | isTcOcc (rdrNameOcc tc)
428
  = return (L loc (setRdrNameSpace tc srcDataName))
429
  | otherwise
430 431 432 433 434 435
  = parseErrorSDoc loc (msg $$ extra)
  where
    msg = text "Not a data constructor:" <+> quotes (ppr tc)
    extra | tc == forall_tv_RDR
	  = text "Perhaps you intended to use -XExistentialQuantification"
	  | otherwise = empty
436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453
\end{code}

Note [Sorting out the result type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a GADT declaration which is not a record, we put the whole constr
type into the ResTyGADT for now; the renamer will unravel it once it
has sorted out operator fixities. Consider for example
     C :: a :*: b -> a :*: b -> a :+: b
Initially this type will parse as
      a :*: (b -> (a :*: (b -> (a :+: b))))

so it's hard to split up the arguments until we've done the precedence
resolution (in the renamer) On the other hand, for a record
	{ x,y :: Int } -> a :*: b
there is no doubt.  AND we need to sort records out so that
we can bring x,y into scope.  So:
   * For PrefixCon we keep all the args in the ResTyGADT
   * For RecCon we do not
454

455
\begin{code}
456 457 458
----------------------------------------------------------------------------
-- Various Syntactic Checks

459 460
checkInstType :: LHsType RdrName -> P (LHsType RdrName)
checkInstType (L l t)
461
  = case t of
462 463 464
	HsForAllTy exp tvs ctxt ty -> do
		dict_ty <- checkDictTy ty
	      	return (L l (HsForAllTy exp tvs ctxt dict_ty))
465 466 467

        HsParTy ty -> checkInstType ty

468 469
	ty ->   do dict_ty <- checkDictTy (L l ty)
	      	   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
470

471 472 473
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
  where
474 475
  check (HsTyVar tc)            args | isRdrTc tc = done tc args
  check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
476 477 478 479
  check (HsAppTy l r) args = check (unLoc l) (r:args)
  check (HsParTy t)   args = check (unLoc t) args
  check _ _ = parseError spn "Malformed instance header"

480 481
  done tc args = return (L spn (HsPredTy (HsClassP tc args)))

482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504
checkTParams :: Bool	  -- Type/data family
	     -> [LHsType RdrName]
	     -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
-- checkTParams checks the type parameters of a data/newtype declaration
-- There are two cases:
--
--  a) Vanilla data/newtype decl. In that case 
--        - the type parameters should all be type variables
--        - they may have a kind annotation
--
--  b) Family data/newtype decl.  In that case
--        - The type parameters may be arbitrary types
--        - We find the type-varaible binders by find the 
--          free type vars of those types
--        - We make them all kind-sig-free binders (UserTyVar)
--          If there are kind sigs in the type parameters, they
--          will fix the binder's kind when we kind-check the 
--          type parameters
checkTParams is_family tparams
  | not is_family        -- Vanilla case (a)
  = do { tyvars <- checkTyVars tparams
       ; return (tyvars, Nothing) }
  | otherwise		 -- Family case (b)
505
  = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
506 507 508
       ; return (tyvars, Just tparams) }

checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
509
-- Check whether the given list of type parameters are all type variables
510
-- (possibly with a kind signature).  If the second argument is `False',
511
-- only type variables are allowed and we raise an error on encountering a
512 513
-- non-variable; otherwise, we allow non-variable arguments and return the
-- entire list of parameters.
514
checkTyVars tparms = mapM chk tparms
515
  where
516
	-- Check that the name space is correct!
517 518 519
    chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
	| isRdrTyVar tv    = return (L l (KindedTyVar tv k))
    chk (L l (HsTyVar tv))
520
        | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
521
    chk (L l _)            =
522
	  parseError l "Type found where type variable expected"
523

524 525 526
checkTyClHdr :: LHsType RdrName
             -> P (Located RdrName,	     -- the head symbol (type or class name)
	           [LHsType RdrName])        -- parameters of head symbol
527
-- Well-formedness check and decomposition of type and class heads.
528 529 530 531 532
-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
-- 		Int :*: Bool   into    (:*:, [Int, Bool])
-- returning the pieces
checkTyClHdr ty
  = goL ty []
533
  where
534
    goL (L l ty) acc = go l ty acc
535

536
    go l (HsTyVar tc) acc 
537 538
	| isRdrTc tc 	     = return (L l tc, acc)
				     
539
    go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
540 541 542 543
	| isRdrTc tc	     = return (ltc, t1:t2:acc)
    go _ (HsParTy ty)    acc = goL ty acc
    go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
    go l _               _   = parseError l "Malformed head of type or class declaration"
544

545 546 547 548 549 550
-- Check that associated type declarations of a class are all kind signatures.
--
checkKindSigs :: [LTyClDecl RdrName] -> P ()
checkKindSigs = mapM_ check
  where
    check (L l tydecl) 
551
      | isFamilyDecl tydecl
552 553 554 555
        || isSynDecl tydecl  = return ()
      | otherwise	     = 
	parseError l "Type declaration in a class must be a kind signature or synonym default"

556 557 558 559 560 561 562 563 564 565
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l t)
  = check t
 where
  check (HsTupleTy _ ts) 	-- (Eq a, Ord b) shows up as a tuple type
    = do ctx <- mapM checkPred ts
	 return (L l ctx)

  check (HsParTy ty)	-- to be sure HsParTy doesn't get into the way
    = check (unLoc ty)
566

567 568
  check (HsTyVar t)	-- Empty context shows up as a unit type ()
    | t == getRdrName unitTyCon = return (L l [])
569

570 571 572
  check t 
    = do p <- checkPred (L l t)
         return (L l [p])
573 574


575
checkPred :: LHsType RdrName -> P (LHsPred RdrName)
576 577 578
-- Watch out.. in ...deriving( Show )... we use checkPred on 
-- the list of partially applied predicates in the deriving,
-- so there can be zero args.
579
checkPred (L spn (HsPredTy (HsIParam n ty)))
580 581 582
  = return (L spn (HsIParam n ty))
checkPred (L spn ty)
  = check spn ty []
583
  where
584
    checkl (L l ty) args = check l ty args
585

586 587 588
    check _loc (HsPredTy pred@(HsEqualP _ _)) 
                                       args | null args
					    = return $ L spn pred
589 590 591 592 593
    check _loc (HsTyVar t)             args | not (isRdrTyVar t) 
		 		  	    = return (L spn (HsClassP t args))
    check _loc (HsAppTy l r)           args = checkl l (r:args)
    check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
    check _loc (HsParTy t)  	       args = checkl t args
594 595
    check loc _                        _    = parseError loc  
					        "malformed class assertion"
596

597 598 599 600 601
---------------------------------------------------------------------------
-- Checking statements in a do-expression
-- 	We parse   do { e1 ; e2 ; }
-- 	as [ExprStmt e1, ExprStmt e2]
-- checkDo (a) checks that the last thing is an ExprStmt
602
--	   (b) returns it separately
603 604
-- same comments apply for mdo as well

605 606
checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)

607 608 609
checkDo	 = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"

610
checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
611 612
checkDoMDo _   nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
checkDoMDo pre nm _   ss   = do
613 614
  check ss
  where 
615
	check  []                     = panic "RdrHsSyn:checkDoMDo"
616
	check  [L _ (ExprStmt e _ _)] = return ([], e)
617 618 619
	check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
					 " construct must be an expression")
	check (s:ss) = do
620 621
	  (ss',e') <-  check ss
	  return ((s:ss'),e')
622

623
-- -------------------------------------------------------------------------
624 625 626 627 628
-- Checking Patterns.

-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.

629 630 631 632 633 634 635 636 637 638 639 640
checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
checkPattern e = checkLPat e

checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
checkPatterns es = mapM checkPattern es

checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
checkLPat e@(L l _) = checkPat l e []

checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
checkPat loc (L l (HsVar c)) args
  | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
641 642 643 644 645 646 647 648 649
checkPat loc e args 	-- OK to let this happen even if bang-patterns
			-- are not enabled, because there is no valid
			-- non-bang-pattern parse of (C ! e)
  | Just (e', args') <- splitBang e
  = do	{ args'' <- checkPatterns args'
	; checkPat loc e' (args'' ++ args) }
checkPat loc (L _ (HsApp f x)) args
  = do { x <- checkLPat x; checkPat loc f (x:args) }
checkPat loc (L _ e) []
650 651 652
  = do { pState <- getPState
       ; p <- checkAPat (dflags pState) loc e
       ; return (L loc p) }
653
checkPat loc _ _
654 655
  = patFail loc

656 657
checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
checkAPat dynflags loc e = case e of
658 659 660
   EWildPat -> return (WildPat placeHolderType)
   HsVar x  -> return (VarPat x)
   HsLit l  -> return (LitPat l)
661 662 663

   -- Overloaded numeric patterns (e.g. f 0 x = x)
   -- Negation is recorded separately, so that the literal is zero or +ve
664
   -- NB. Negative *primitive* literals are already handled by the lexer
665
   HsOverLit pos_lit          -> return (mkNPat pos_lit Nothing)
666
   NegApp (L _ (HsOverLit pos_lit)) _ 
667
			-> return (mkNPat pos_lit (Just noSyntaxExpr))
668
   
669 670 671 672
   SectionR (L _ (HsVar bang)) e 	-- (! x)
 	| bang == bang_RDR 
	-> do { bang_on <- extension bangPatEnabled
	      ; if bang_on then checkLPat e >>= (return . BangPat)
673
		else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
674

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
675 676
   ELazyPat e	      -> checkLPat e >>= (return . LazyPat)
   EAsPat n e	      -> checkLPat e >>= (return . AsPat n)
677 678
   -- view pattern is well-formed if the pattern is
   EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
679 680 681 682 683 684 685 686
   ExprWithTySig e t  -> do e <- checkLPat e
                            -- Pattern signatures are parsed as sigtypes,
                            -- but they aren't explicit forall points.  Hence
                            -- we have to remove the implicit forall here.
                            let t' = case t of 
                                       L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
                                       other -> other
                            return (SigPatIn e t')
687 688 689
   
   -- n+k patterns
   OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ 
690
	 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
691
   		      | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
692 693
   		      -> return (mkNPlusKPat (L nloc n) lit)
   
694 695 696 697 698 699
   OpApp l op _fix r  -> do l <- checkLPat l
                            r <- checkLPat r
                            case op of
                               L cl (HsVar c) | isDataOcc (rdrNameOcc c)
                                      -> return (ConPatIn (L cl c) (InfixCon l r))
                               _ -> patFail loc
700
   
701
   HsPar e	      -> checkLPat e >>= (return . ParPat)
Ian Lynagh's avatar
Ian Lynagh committed
702
   ExplicitList _ es  -> do ps <- mapM checkLPat es
703
                            return (ListPat ps placeHolderType)
Ian Lynagh's avatar
Ian Lynagh committed
704
   ExplicitPArr _ es  -> do ps <- mapM checkLPat es
705
                            return (PArrPat ps placeHolderType)
706
   
707 708 709 710
   ExplicitTuple es b 
     | all tupArgPresent es  -> do ps <- mapM checkLPat [e | Present e <- es]
                                   return (TuplePat ps b placeHolderType)
     | otherwise -> parseError loc "Illegal tuple section in pattern"
711
   
712 713 714
   RecordCon c _ (HsRecFields fs dd)
                      -> do fs <- mapM checkPatField fs
                            return (ConPatIn c (RecCon (HsRecFields fs dd)))
715
   HsQuasiQuoteE q    -> return (QuasiQuotePat q)
716
-- Generics 
717 718
   HsType ty          -> return (TypePat ty) 
   _                  -> patFail loc
719

720
placeHolderPunRhs :: LHsExpr RdrName
721 722
-- The RHS of a punned record field will be filled in by the renamer
-- It's better not to make it an error, in case we want to print it when debugging
723
placeHolderPunRhs = noLoc (HsVar pun_RDR)
724 725

plus_RDR, bang_RDR, pun_RDR :: RdrName
Ian Lynagh's avatar
Ian Lynagh committed
726 727
plus_RDR = mkUnqual varName (fsLit "+")	-- Hack
bang_RDR = mkUnqual varName (fsLit "!")	-- Hack
728
pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
729

730 731 732
checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
checkPatField fld = do	{ p <- checkLPat (hsRecFieldArg fld)
			; return (fld { hsRecFieldArg = p }) }
733

734
patFail :: SrcSpan -> P a
735
patFail loc = parseError loc "Parse error in pattern"
736 737 738 739 740


---------------------------------------------------------------------------
-- Check Equation Syntax

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
741 742 743 744 745
checkValDef :: LHsExpr RdrName
	    -> Maybe (LHsType RdrName)
	    -> Located (GRHSs RdrName)
	    -> P (HsBind RdrName)

746 747 748 749
checkValDef lhs (Just sig) grhss
   	-- x :: ty = rhs  parses as a *pattern* binding
  = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
750 751 752 753 754 755 756
checkValDef lhs opt_sig grhss
  = do	{ mb_fun <- isFunLhs lhs
	; case mb_fun of
	    Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
						fun is_infix pats opt_sig grhss
	    Nothing -> checkPatBind lhs grhss }

757 758 759 760 761 762 763
checkFunBind :: SrcSpan
             -> Located RdrName
             -> Bool
             -> [LHsExpr RdrName]
             -> Maybe (LHsType RdrName)
             -> Located (GRHSs RdrName)
             -> P (HsBind RdrName)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
764 765 766
checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
  = do	ps <- checkPatterns pats
	let match_span = combineSrcSpans lhs_loc rhs_span
767
	return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
768 769
	-- The span of the match covers the entire equation.  
	-- That isn't quite right, but it'll do for now.
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
770

771 772 773 774
makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
makeFunBind fn is_infix ms 
  = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
andy@galois.com's avatar
andy@galois.com committed
775
	      fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
776

777 778 779
checkPatBind :: LHsExpr RdrName
             -> Located (GRHSs RdrName)
             -> P (HsBind RdrName)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
780 781 782
checkPatBind lhs (L _ grhss)
  = do	{ lhs <- checkPattern lhs
	; return (PatBind lhs grhss placeHolderType placeHolderNames) }
783 784

checkValSig
785 786 787
	:: LHsExpr RdrName
	-> LHsType RdrName
	-> P (Sig RdrName)
788 789 790
checkValSig (L l (HsVar v)) ty 
  | isUnqual v && not (isDataOcc (rdrNameOcc v))
  = return (TypeSig (L l v) ty)
791 792 793 794
checkValSig lhs@(L l _)         _
  | looks_like_foreign lhs
  = parseError l "Invalid type signature; perhaps you meant to use -XForeignFunctionInterface?"
  | otherwise
795
  = parseError l "Invalid type signature: should be of form <variable> :: <type>"
796 797 798 799 800 801 802 803 804
  where
    -- A common error is to forget the ForeignFunctionInterface flag
    -- so check for that, and suggest.  cf Trac #3805
    -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
    looks_like_foreign (L _ (HsVar v))     = v == foreign_RDR
    looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
    looks_like_foreign _                   = False

    foreign_RDR = mkUnqual varName (fsLit "foreign")
805
\end{code}
806

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
807

808
\begin{code}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
809 810 811
	-- The parser left-associates, so there should 
	-- not be any OpApps inside the e's
splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
812
-- Splits (f ! g a b) into (f, [(! g), a, b])
813
splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
814 815 816 817 818
  | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
  where
    (arg1,argns) = split_bang r_arg []
    split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
    split_bang e	   	 es = (e,es)
819
splitBang _ = Nothing
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
820 821 822

isFunLhs :: LHsExpr RdrName 
	 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
823
-- A variable binding is parsed as a FunBind.
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
824
-- Just (fun, is_infix, arg_pats) if e is a function LHS
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
825 826 827 828 829 830 831 832 833 834
--
-- The whole LHS is parsed as a single expression.  
-- Any infix operators on the LHS will parse left-associatively
-- E.g. 	f !x y !z
-- 	will parse (rather strangely) as 
--		(f ! x y) ! z
-- 	It's up to isFunLhs to sort out the mess
--
-- a .!. !b 

835
isFunLhs e = go e []
836
 where
837
   go (L loc (HsVar f)) es 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
838
	| not (isRdrDataCon f)	 = return (Just (L loc f, False, es))
839 840
   go (L _ (HsApp f e)) es 	 = go f (e:es)
   go (L _ (HsPar e))   es@(_:_) = go e es
841 842 843 844 845 846 847 848 849 850 851 852 853 854

	-- For infix function defns, there should be only one infix *function*
	-- (though there may be infix *datacons* involved too).  So we don't
	-- need fixity info to figure out which function is being defined.
	--	a `K1` b `op` c `K2` d
	-- must parse as
	--	(a `K1` b) `op` (c `K2` d)
	-- The renamer checks later that the precedences would yield such a parse.
	-- 
	-- There is a complication to deal with bang patterns.
	--
	-- ToDo: what about this?
	--		x + 1 `op` y = ...

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
855 856 857 858 859 860
   go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
	| Just (e',es') <- splitBang e
	= do { bang_on <- extension bangPatEnabled
	     ; if bang_on then go e' (es' ++ es)
	       else return (Just (L loc' op, True, (l:r:es))) }
		-- No bangs; behave just like the next case
861
	| not (isRdrDataCon op) 	-- We have found the function!
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
862
	= return (Just (L loc' op, True, (l:r:es)))
863
	| otherwise			-- Infix data con; keep going
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
864 865 866 867 868 869 870 871
	= do { mb_l <- go l es
	     ; case mb_l of
		 Just (op', True, j : k : es')
		    -> return (Just (op', True, j : op_app : es'))
		    where
		      op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
		 _ -> return Nothing }
   go _ _ = return Nothing
872 873 874 875

---------------------------------------------------------------------------
-- Miscellaneous utilities

876 877 878 879
checkPrecP :: Located Int -> P Int
checkPrecP (L l i)
 | 0 <= i && i <= maxPrecedence = return i
 | otherwise     	        = parseError l "Precedence out of range"
880 881

mkRecConstrOrUpdate 
882 883
	:: LHsExpr RdrName 
	-> SrcSpan
884
	-> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
885 886
	-> P (HsExpr RdrName)

887
mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
888 889 890 891 892
  = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp loc (fs,dd)
  | null fs   = parseError loc "Empty record update"
  | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])

893
mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
894 895
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
896

897 898 899 900
mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
-- The Maybe is because the user can omit the activation spec (and usually does)
mkInlinePragma mb_act match_info inl 
  = InlinePragma { inl_inline = inl
901
                 , inl_sat    = Nothing
902 903 904 905 906 907 908 909 910 911
                 , inl_act    = act
                 , inl_rule   = match_info }
  where
    act = case mb_act of
            Just act -> act
            Nothing | inl       -> AlwaysActive
                    | otherwise -> NeverActive
        -- If no specific phase is given then:
	--   NOINLINE => NeverActive
        --   INLINE   => Active
912

913 914 915 916 917
-----------------------------------------------------------------------------
-- utilities for foreign declarations

-- construct a foreign import declaration
--
918
mkImport :: CCallConv
919
	 -> Safety 
920 921
	 -> (Located FastString, Located RdrName, LHsType RdrName) 
	 -> P (HsDecl RdrName)
922
mkImport cconv safety (L loc entity, v, ty)
923
  | cconv == PrimCallConv                      = do
924
  let funcTarget = CFunction (StaticTarget entity Nothing)
925 926 927
      importSpec = CImport PrimCallConv safety nilFS funcTarget
  return (ForD (ForeignImport v ty importSpec))

928
  | otherwise = do
929 930 931
    case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
      Nothing         -> parseError loc "Malformed entity string"
      Just importSpec -> return (ForD (ForeignImport v ty importSpec))
932

933 934 935 936 937 938 939 940 941
-- the string "foo" is ambigous: either a header or a C identifier.  The
-- C identifier case comes first in the alternatives below, so we pick
-- that one.
parseCImport :: CCallConv -> Safety -> FastString -> String
             -> Maybe ForeignImport
parseCImport cconv safety nm str =
 listToMaybe $ map fst $ filter (null.snd) $ 
     readP_to_S parse str
 where
942 943 944
   parse = do
       skipSpaces
       r <- choice [
945 946 947 948 949
          string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
          string "wrapper" >> return (mk nilFS CWrapper),
          optional (string "static" >> skipSpaces) >> 
           (mk nilFS <$> cimp nm) +++
           (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
950 951 952
         ]
       skipSpaces
       return r
953 954 955

   mk = CImport cconv safety

956 957 958
   hdr_char c = not (isSpace c) -- header files are filenames, which can contain
                                -- pretty much any char (depending on the platform),
                                -- so just accept any non-space character
959 960 961
   id_char  c = isAlphaNum c || c == '_'

   cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
962
             +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
963 964 965 966 967 968
          where 
            cid = return nm +++
                  (do c  <- satisfy (\c -> isAlpha c || c == '_')
                      cs <-  many (satisfy id_char)
                      return (mkFastString (c:cs)))

969 970 971

-- construct a foreign export declaration
--
972
mkExport :: CCallConv
973 974
         -> (Located FastString, Located RdrName, LHsType RdrName) 
	 -> P (HsDecl RdrName)
975
mkExport cconv (L _ entity, v, ty) = return $
Simon Marlow's avatar
Simon Marlow committed
976
  ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
977
  where
978 979
    entity' | nullFS entity = mkExtName (unLoc v)
	    | otherwise     = entity
980 981 982 983 984 985 986 987

-- Supplying the ext_name in a foreign decl is optional; if it
-- isn't there, the Haskell name is assumed. Note that no transformation
-- of the Haskell name is then performed, so if you foreign export (++),
-- it's external name will be "++". Too bad; it's important because we don't
-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
--
mkExtName :: RdrName -> CLabelString
988
mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
989
\end{code}