ghc/compiler/parser/RdrHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
   5
   6 (Well, really, for specialisations involving @RdrName@s, even if
   7 they are used somewhat later on in the compiler...)
   8
   9 \begin{code}
  10 module RdrHsSyn (
  11         RdrNameArithSeqInfo,
  12         RdrNameBangType,
  13         RdrNameClassOpSig,
  14         RdrNameConDecl,
  15         RdrNameConDetails,
  16         RdrNameContext,
  17         RdrNameDefaultDecl,
  18         RdrNameForeignDecl,
  19         RdrNameGRHS,
  20         RdrNameGRHSs,
  21         RdrNameHsBinds,
  22         RdrNameHsCmd,
  23         RdrNameHsCmdTop,
  24         RdrNameHsDecl,
  25         RdrNameHsExpr,
  26         RdrNameHsModule,
  27         RdrNameIE,
  28         RdrNameImportDecl,
  29         RdrNameInstDecl,
  30         RdrNameMatch,
  31         RdrNameMonoBinds,
  32         RdrNamePat,
  33         RdrNameHsType,
  34         RdrNameHsTyVar,
  35         RdrNameSig,
  36         RdrNameStmt,
  37         RdrNameTyClDecl,
  38         RdrNameRuleDecl,
  39         RdrNameRuleBndr,
  40         RdrNameDeprecation,
  41         RdrNameHsRecordBinds,
  42         RdrNameFixitySig,
  43
  44         RdrBinding(..),
  45         RdrMatch(..),
  46
  47         main_RDR_Unqual,
  48
  49         extractHsTyRdrTyVars,
  50         extractHsRhoRdrTyVars, extractGenericPatTyVars,
  51
  52         mkHsOpApp, mkClassDecl,
  53         mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
  54         mkHsDo, mkHsSplice, mkSigDecls,
  55         mkTyData, mkPrefixCon, mkRecCon,
  56         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
  57         mkBootIface,
  58
  59         cvBinds,
  60         cvMonoBindsAndSigs,
  61         cvTopDecls,
  62         findSplice, addImpDecls, emptyGroup, mkGroup,
  63
  64         -- Stuff to do with Foreign declarations
  65         , CallConv(..)
  66         , mkImport            -- CallConv -> Safety
  67                               -- -> (FastString, RdrName, RdrNameHsType)
  68                               -- -> SrcLoc
  69                               -- -> P RdrNameHsDecl
  70         , mkExport            -- CallConv
  71                               -- -> (FastString, RdrName, RdrNameHsType)
  72                               -- -> SrcLoc
  73                               -- -> P RdrNameHsDecl
  74         , mkExtName           -- RdrName -> CLabelString
  75
  76         -- Bunch of functions in the parser monad for
  77         -- checking and constructing values
  78         , checkPrecP          -- Int -> P Int
  79         , checkContext        -- HsType -> P HsContext
  80         , checkPred           -- HsType -> P HsPred
  81         , checkTyVars         -- [HsTyVar] -> P [HsType]
  82         , checkTyClHdr        -- HsType -> (name,[tyvar])
  83         , checkInstType       -- HsType -> P HsType
  84         , checkPattern        -- HsExp -> P HsPat
  85         , checkPatterns       -- SrcLoc -> [HsExp] -> P [HsPat]
  86         , checkDo             -- [Stmt] -> P [Stmt]
  87         , checkMDo            -- [Stmt] -> P [Stmt]
  88         , checkValDef         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  89         , checkValSig         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  90         , parseError          -- String -> Pa
  91     ) where
  92
  93 #include "HsVersions.h"
  94
  95 import HsSyn            -- Lots of it
  96 import IfaceType
  97 import HscTypes         ( ModIface(..), emptyModIface, mkIfaceVerCache )
  98 import IfaceSyn         ( IfaceDecl(..), IfaceIdInfo(..) )
  99 import RdrName          ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc,
 100                           isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
 101                           setRdrNameSpace, rdrNameModule )
 102 import BasicTypes       ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
 103 import Lexer            ( P, setSrcLocFor, getSrcLoc, failLocMsgP )
 104 import HscTypes         ( GenAvailInfo(..) )
 105 import TysWiredIn       ( unitTyCon )
 106 import ForeignCall      ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
 107                           DNCallSpec(..), DNKind(..))
 108 import OccName          ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
 109                           occNameUserString, mkVarOcc, isValOcc )
 110 import BasicTypes       ( initialVersion )
 111 import TyCon            ( DataConDetails(..) )
 112 import Module           ( ModuleName )
 113 import SrcLoc
 114 import CStrings         ( CLabelString )
 115 import CmdLineOpts      ( opt_InPackage )
 116 import List             ( isSuffixOf, nub )
 117 import Outputable
 118 import FastString
 119 import Panic
 120 \end{code}
 121
 122
 123 %************************************************************************
 124 %*                                                                      *
 125 \subsection{Type synonyms}
 126 %*                                                                      *
 127 %************************************************************************
 128
 129 \begin{code}
 130 type RdrNameArithSeqInfo        = ArithSeqInfo          RdrName
 131 type RdrNameBangType            = BangType              RdrName
 132 type RdrNameClassOpSig          = Sig                   RdrName
 133 type RdrNameConDecl             = ConDecl               RdrName
 134 type RdrNameConDetails          = HsConDetails          RdrName RdrNameBangType
 135 type RdrNameContext             = HsContext             RdrName
 136 type RdrNameHsDecl              = HsDecl                RdrName
 137 type RdrNameDefaultDecl         = DefaultDecl           RdrName
 138 type RdrNameForeignDecl         = ForeignDecl           RdrName
 139 type RdrNameGRHS                = GRHS                  RdrName
 140 type RdrNameGRHSs               = GRHSs                 RdrName
 141 type RdrNameHsBinds             = HsBinds               RdrName
 142 type RdrNameHsExpr              = HsExpr                RdrName
 143 type RdrNameHsCmd               = HsCmd                 RdrName
 144 type RdrNameHsCmdTop            = HsCmdTop              RdrName
 145 type RdrNameHsModule            = HsModule              RdrName
 146 type RdrNameIE                  = IE                    RdrName
 147 type RdrNameImportDecl          = ImportDecl            RdrName
 148 type RdrNameInstDecl            = InstDecl              RdrName
 149 type RdrNameMatch               = Match                 RdrName
 150 type RdrNameMonoBinds           = MonoBinds             RdrName
 151 type RdrNamePat                 = InPat                 RdrName
 152 type RdrNameHsType              = HsType                RdrName
 153 type RdrNameHsTyVar             = HsTyVarBndr           RdrName
 154 type RdrNameSig                 = Sig                   RdrName
 155 type RdrNameStmt                = Stmt                  RdrName
 156 type RdrNameTyClDecl            = TyClDecl              RdrName
 157
 158 type RdrNameRuleBndr            = RuleBndr              RdrName
 159 type RdrNameRuleDecl            = RuleDecl              RdrName
 160 type RdrNameDeprecation         = DeprecDecl            RdrName
 161 type RdrNameFixitySig           = FixitySig             RdrName
 162
 163 type RdrNameHsRecordBinds       = HsRecordBinds         RdrName
 164 \end{code}
 165
 166 \begin{code}
 167 main_RDR_Unqual :: RdrName
 168 main_RDR_Unqual = mkUnqual varName FSLIT("main")
 169         -- We definitely don't want an Orig RdrName, because
 170         -- main might, in principle, be imported into module Main
 171 \end{code}
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection{A few functions over HsSyn at RdrName}
 176 %*                                                                    *
 177 %************************************************************************
 178
 179 @extractHsTyRdrNames@ finds the free variables of a HsType
 180 It's used when making the for-alls explicit.
 181
 182 \begin{code}
 183 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
 184 extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
 185
 186 extractHsRhoRdrTyVars :: HsContext RdrName -> RdrNameHsType -> [RdrName]
 187 -- This one takes the context and tau-part of a
 188 -- sigma type and returns their free type variables
 189 extractHsRhoRdrTyVars ctxt ty = nub $ filter isRdrTyVar $
 190                                 extract_ctxt ctxt (extract_ty ty [])
 191
 192 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
 193
 194 extract_pred (HsClassP cls tys) acc     = foldr extract_ty (cls : acc) tys
 195 extract_pred (HsIParam n ty) acc        = extract_ty ty acc
 196
 197 extract_ty (HsAppTy ty1 ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
 198 extract_ty (HsListTy ty)             acc = extract_ty ty acc
 199 extract_ty (HsPArrTy ty)             acc = extract_ty ty acc
 200 extract_ty (HsTupleTy _ tys)         acc = foldr extract_ty acc tys
 201 extract_ty (HsFunTy ty1 ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
 202 extract_ty (HsPredTy p)              acc = extract_pred p acc
 203 extract_ty (HsTyVar tv)              acc = tv : acc
 204 extract_ty (HsOpTy ty1 nam ty2)      acc = extract_ty ty1 (extract_ty ty2 acc)
 205 extract_ty (HsParTy ty)              acc = extract_ty ty acc
 206 extract_ty (HsNumTy num)             acc = acc
 207 extract_ty (HsKindSig ty k)          acc = extract_ty ty acc
 208 extract_ty (HsForAllTy exp [] cx ty) acc = extract_ctxt cx (extract_ty ty acc)
 209 extract_ty (HsForAllTy exp tvs cx ty)
 210                                 acc = acc ++
 211                                       (filter (`notElem` locals) $
 212                                        extract_ctxt cx (extract_ty ty []))
 213                                     where
 214                                       locals = hsTyVarNames tvs
 215
 216 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
 217 -- Get the type variables out of the type patterns in a bunch of
 218 -- possibly-generic bindings in a class declaration
 219 extractGenericPatTyVars binds
 220   = filter isRdrTyVar (nub (get binds []))
 221   where
 222     get (AndMonoBinds b1 b2)   acc = get b1 (get b2 acc)
 223     get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
 224     get other                  acc = acc
 225
 226     get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc
 227     get_m other                        acc = acc
 228 \end{code}
 229
 230
 231 %************************************************************************
 232 %*                                                                      *
 233 \subsection{Construction functions for Rdr stuff}
 234 %*                                                                    *
 235 %************************************************************************
 236
 237 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 238 by deriving them from the name of the class.  We fill in the names for the
 239 tycon and datacon corresponding to the class, by deriving them from the
 240 name of the class itself.  This saves recording the names in the interface
 241 file (which would be equally good).
 242
 243 Similarly for mkConDecl, mkClassOpSig and default-method names.
 244
 245         *** See "THE NAMING STORY" in HsDecls ****
 246
 247 \begin{code}
 248 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
 249   = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
 250                 tcdFDs = fds,
 251                 tcdSigs = sigs,
 252                 tcdMeths = mbinds,
 253                 tcdLoc = loc }
 254
 255 mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
 256   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
 257              tcdTyVars = tyvars,  tcdCons = data_cons,
 258              tcdDerivs = maybe,   tcdLoc = src }
 259 \end{code}
 260
 261 \begin{code}
 262 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
 263 -- If the type checker sees (negate 3#) it will barf, because negate
 264 -- can't take an unboxed arg.  But that is exactly what it will see when
 265 -- we write "-3#".  So we have to do the negation right now!
 266
 267 mkHsNegApp (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 268 mkHsNegApp (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 269 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 270 mkHsNegApp expr                     = NegApp expr placeHolderName
 271 \end{code}
 272
 273 A useful function for building @OpApps@.  The operator is always a
 274 variable, and we don't know the fixity yet.
 275
 276 \begin{code}
 277 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 278 \end{code}
 279
 280 These are the bits of syntax that contain rebindable names
 281 See RnEnv.lookupSyntaxName
 282
 283 \begin{code}
 284 mkHsIntegral   i      = HsIntegral   i  placeHolderName
 285 mkHsFractional f      = HsFractional f  placeHolderName
 286 mkNPlusKPat n k       = NPlusKPatIn n k placeHolderName
 287 mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
 288 \end{code}
 289
 290 \begin{code}
 291 mkHsSplice e loc = HsSplice unqualSplice e loc
 292
 293 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
 294                 -- A name (uniquified later) to
 295                 -- identify the splice
 296 \end{code}
 297
 298 %************************************************************************
 299 %*                                                                      *
 300                 Hi-boot files
 301 %*                                                                      *
 302 %************************************************************************
 303
 304 mkBootIface, and its boring helper functions, have two purposes:
 305 a) HsSyn to IfaceSyn.  The parser parses the former, but we're reading
 306         an hi-boot file, and interfaces consist of the latter
 307 b) Convert unqualifed names from the "current module" to qualified Orig
 308    names.  E.g.
 309         module This where
 310          foo :: GHC.Base.Int -> GHC.Base.Int
 311    becomes
 312          This.foo :: GHC.Base.Int -> GHC.Base.Int
 313
 314 It assumes that everything is well kinded, of course.
 315
 316 \begin{code}
 317 mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
 318 -- Make the ModIface for a hi-boot file
 319 -- The decls are of very limited form
 320 mkBootIface mod decls
 321   = (emptyModIface opt_InPackage mod) {
 322         mi_boot     = True,
 323         mi_exports  = [(mod, map mk_export decls')],
 324         mi_decls    = decls_w_vers,
 325         mi_ver_fn   = mkIfaceVerCache decls_w_vers }
 326   where
 327     decls' = map hsIfaceDecl decls
 328     decls_w_vers = repeat initialVersion `zip` decls'
 329
 330                 -- hi-boot declarations don't (currently)
 331                 -- expose constructors or class methods
 332     mk_export decl | isValOcc occ = Avail occ
 333                    | otherwise    = AvailTC occ [occ]
 334                    where
 335                      occ = ifName decl
 336
 337
 338 hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
 339         -- Change to Iface syntax, and replace unqualified names with
 340         -- qualified Orig names from this module.  Reason: normal
 341         -- iface files have everything fully qualified, so it's convenient
 342         -- for hi-boot files to look the same
 343         --
 344         -- NB: no constructors or class ops to worry about
 345 hsIfaceDecl (SigD (Sig name ty _))
 346   = IfaceId { ifName = rdrNameOcc name,
 347               ifType = hsIfaceType ty,
 348               ifIdInfo = NoInfo }
 349
 350 hsIfaceDecl (TyClD decl@(TySynonym {}))
 351   = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
 352                ifTyVars = hsIfaceTvs (tcdTyVars decl),
 353                ifSynRhs = hsIfaceType (tcdSynRhs decl),
 354                ifVrcs = [] }
 355
 356 hsIfaceDecl (TyClD decl@(TyData {}))
 357   = IfaceData { ifND = tcdND decl,
 358                 ifName = rdrNameOcc (tcdName decl),
 359                 ifTyVars = hsIfaceTvs (tcdTyVars decl),
 360                 ifCtxt = hsIfaceCtxt (tcdCtxt decl),
 361                 ifCons = Unknown, ifRec = NonRecursive,
 362                 ifVrcs = [], ifGeneric = False }
 363
 364 hsIfaceDecl (TyClD decl@(ClassDecl {}))
 365   = IfaceClass { ifName = rdrNameOcc (tcdName decl),
 366                  ifTyVars = hsIfaceTvs (tcdTyVars decl),
 367                  ifCtxt = hsIfaceCtxt (tcdCtxt decl),
 368                  ifFDs = hsIfaceFDs (tcdFDs decl),
 369                  ifSigs = [],   -- Is this right??
 370                  ifRec = NonRecursive, ifVrcs = [] }
 371
 372 hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
 373
 374 hsIfaceName rdr_name    -- Qualify unqualifed occurrences
 375                                 -- with the module name
 376   | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
 377   | otherwise         = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 378
 379 hsIfaceType :: HsType RdrName -> IfaceType
 380 hsIfaceType (HsForAllTy exp tvs cxt ty)
 381   = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
 382   where
 383     rho = foldr (IfaceFunTy . IfacePredTy . hsIfacePred) tau cxt
 384     tau = hsIfaceType ty
 385     tvs' = case exp of
 386              Explicit -> tvs
 387              Implicit -> map UserTyVar (extractHsRhoRdrTyVars cxt ty)
 388
 389 hsIfaceType ty@(HsTyVar _)     = hs_tc_app ty []
 390 hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
 391 hsIfaceType (HsFunTy t1 t2)    = IfaceFunTy (hsIfaceType t1) (hsIfaceType t2)
 392 hsIfaceType (HsListTy t)       = IfaceTyConApp IfaceListTc [hsIfaceType t]
 393 hsIfaceType (HsPArrTy t)       = IfaceTyConApp IfacePArrTc [hsIfaceType t]
 394 hsIfaceType (HsTupleTy bx ts)  = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceTypes ts)
 395 hsIfaceType (HsOpTy t1 tc t2)  = hs_tc_app (HsTyVar tc) (hsIfaceTypes [t1, t2])
 396 hsIfaceType (HsParTy t)        = hsIfaceType t
 397 hsIfaceType (HsNumTy n)        = panic "hsIfaceType:HsNum"
 398 hsIfaceType (HsPredTy p)       = IfacePredTy (hsIfacePred p)
 399 hsIfaceType (HsKindSig t _)    = hsIfaceType t
 400
 401 -----------
 402 hsIfaceTypes tys = map hsIfaceType tys
 403
 404 -----------
 405 hsIfaceCtxt :: [HsPred RdrName] -> [IfacePredType]
 406 hsIfaceCtxt ctxt = map hsIfacePred ctxt
 407
 408 -----------
 409 hsIfacePred :: HsPred RdrName -> IfacePredType
 410 hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceTypes ts)
 411 hsIfacePred (HsIParam ip t)   = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceType t)
 412
 413 -----------
 414 hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
 415 hs_tc_app (HsAppTy t1 t2) args = hs_tc_app t1 (hsIfaceType t2 : args)
 416 hs_tc_app (HsTyVar n) args
 417   | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
 418   | otherwise              = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
 419 hs_tc_app ty args          = foldl IfaceAppTy (hsIfaceType ty) args
 420
 421 -----------
 422 hsIfaceTvs tvs = map hsIfaceTv tvs
 423
 424 -----------
 425 hsIfaceTv (UserTyVar n)     = (rdrNameOcc n, IfaceLiftedTypeKind)
 426 hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k)
 427
 428 -----------
 429 hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
 430 hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
 431                  | (xs,ys) <- fds ]
 432 \end{code}
 433
 434
 435 %************************************************************************
 436 %*                                                                      *
 437 \subsection[rdrBinding]{Bindings straight out of the parser}
 438 %*                                                                      *
 439 %************************************************************************
 440
 441 \begin{code}
 442 data RdrBinding
 443   =   -- Value bindings havn't been united with their
 444       -- signatures yet
 445     RdrBindings [RdrBinding]    -- Convenience for parsing
 446
 447   | RdrValBinding     RdrNameMonoBinds
 448
 449       -- The remainder all fit into the main HsDecl form
 450   | RdrHsDecl         RdrNameHsDecl
 451 \end{code}
 452
 453 \begin{code}
 454 data RdrMatch
 455   = RdrMatch
 456              [RdrNamePat]
 457              (Maybe RdrNameHsType)
 458              RdrNameGRHSs
 459 \end{code}
 460
 461 %************************************************************************
 462 %*                                                                      *
 463 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
 464 %*                                                                      *
 465 %************************************************************************
 466
 467 Function definitions are restructured here. Each is assumed to be recursive
 468 initially, and non recursive definitions are discovered by the dependency
 469 analyser.
 470
 471
 472 \begin{code}
 473 cvTopDecls :: [RdrBinding] -> [RdrNameHsDecl]
 474 -- Incoming bindings are in reverse order; result is in ordinary order
 475 -- (a) flatten RdrBindings
 476 -- (b) Group together bindings for a single function
 477 cvTopDecls decls
 478   = go [] decls
 479   where
 480     go :: [RdrNameHsDecl] -> [RdrBinding] -> [RdrNameHsDecl]
 481     go acc []                      = acc
 482     go acc (RdrBindings ds1 : ds2) = go (go acc ds1)    ds2
 483     go acc (RdrHsDecl d : ds)      = go (d       : acc) ds
 484     go acc (RdrValBinding b : ds)  = go (ValD b' : acc) ds'
 485                                    where
 486                                      (b', ds') = getMonoBind b ds
 487
 488 cvBinds :: [RdrBinding] -> RdrNameHsBinds
 489 cvBinds binding
 490   = case (cvMonoBindsAndSigs binding) of { (mbs, sigs) ->
 491     MonoBind mbs sigs Recursive
 492     }
 493
 494 cvMonoBindsAndSigs :: [RdrBinding] -> (RdrNameMonoBinds, [RdrNameSig])
 495 -- Input bindings are in *reverse* order,
 496 -- and contain just value bindings and signatuers
 497
 498 cvMonoBindsAndSigs  fb
 499   = go (EmptyMonoBinds, []) fb
 500   where
 501     go acc      []                        = acc
 502     go acc      (RdrBindings ds1 : ds2)   = go (go acc ds1) ds2
 503     go (bs, ss) (RdrHsDecl (SigD s) : ds) = go (bs, s : ss) ds
 504     go (bs, ss) (RdrValBinding b : ds)    = go (b' `AndMonoBinds` bs, ss) ds'
 505                                           where
 506                                             (b',ds') = getMonoBind b ds
 507
 508 -----------------------------------------------------------------------------
 509 -- Group function bindings into equation groups
 510
 511 getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBinding])
 512 -- Suppose      (b',ds') = getMonoBind b ds
 513 --      ds is a *reversed* list of parsed bindings
 514 --      b is a MonoBinds that has just been read off the front
 515
 516 -- Then b' is the result of grouping more equations from ds that
 517 -- belong with b into a single MonoBinds, and ds' is the depleted
 518 -- list of parsed bindings.
 519 --
 520 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 521
 522 getMonoBind (FunMonoBind f inf mtchs loc) binds
 523   | has_args mtchs
 524   = go mtchs loc binds
 525   where
 526     go mtchs1 loc1 (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds)
 527         | f == f2 = go (mtchs2 ++ mtchs1) loc2 binds
 528         -- Remember binds is reversed, so glue mtchs2 on the front
 529         -- and use loc2 as the final location
 530     go mtchs1 loc1 binds = (FunMonoBind f inf mtchs1 loc1, binds)
 531
 532 getMonoBind bind binds = (bind, binds)
 533
 534 has_args ((Match args _ _) : _) = not (null args)
 535         -- Don't group together FunMonoBinds if they have
 536         -- no arguments.  This is necessary now that variable bindings
 537         -- with no arguments are now treated as FunMonoBinds rather
 538         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 539 \end{code}
 540
 541 \begin{code}
 542 emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive,
 543                         -- The renamer adds structure to the bindings;
 544                         -- they start life as a single giant MonoBinds
 545                        hs_tyclds = [], hs_instds = [],
 546                        hs_fixds = [], hs_defds = [], hs_fords = [],
 547                        hs_depds = [] ,hs_ruleds = [] }
 548
 549 findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
 550 findSplice ds = add emptyGroup ds
 551
 552 mkGroup :: [HsDecl a] -> HsGroup a
 553 mkGroup ds = addImpDecls emptyGroup ds
 554
 555 addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a
 556 -- The decls are imported, and should not have a splice
 557 addImpDecls group decls = case add group decls of
 558                                 (group', Nothing) -> group'
 559                                 other             -> panic "addImpDecls"
 560
 561 add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
 562         -- This stuff reverses the declarations (again) but it doesn't matter
 563
 564 -- Base cases
 565 add gp []               = (gp, Nothing)
 566 add gp (SpliceD e : ds) = (gp, Just (e, ds))
 567
 568 -- Class declarations: pull out the fixity signatures to the top
 569 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds)
 570         | isClassDecl d = add (gp { hs_tyclds = d : ts,
 571                                     hs_fixds  = [f | FixSig f <- tcdSigs d] ++ fs }) ds
 572         | otherwise     = add (gp { hs_tyclds = d : ts }) ds
 573
 574 -- Signatures: fixity sigs go a different place than all others
 575 add gp@(HsGroup {hs_fixds = ts}) (SigD (FixSig f) : ds) = add (gp {hs_fixds = f : ts}) ds
 576 add gp@(HsGroup {hs_valds = ts}) (SigD d : ds)          = add (gp {hs_valds = add_sig d ts}) ds
 577
 578 -- Value declarations: use add_bind
 579 add gp@(HsGroup {hs_valds  = ts}) (ValD d : ds) = add (gp { hs_valds = add_bind d ts }) ds
 580
 581 -- The rest are routine
 582 add gp@(HsGroup {hs_instds = ts}) (InstD d : ds)   = add (gp { hs_instds = d : ts }) ds
 583 add gp@(HsGroup {hs_defds  = ts}) (DefD d : ds)    = add (gp { hs_defds = d : ts }) ds
 584 add gp@(HsGroup {hs_fords  = ts}) (ForD d : ds)    = add (gp { hs_fords = d : ts }) ds
 585 add gp@(HsGroup {hs_depds  = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds
 586 add gp@(HsGroup {hs_ruleds  = ts})(RuleD d : ds)   = add (gp { hs_ruleds = d : ts }) ds
 587
 588 add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r
 589 add_sig  s (MonoBind bs sigs r) = MonoBind bs                (s:sigs) r
 590 \end{code}
 591
 592 %************************************************************************
 593 %*                                                                      *
 594 \subsection[PrefixToHS-utils]{Utilities for conversion}
 595 %*                                                                      *
 596 %************************************************************************
 597
 598
 599 \begin{code}
 600 -----------------------------------------------------------------------------
 601 -- mkPrefixCon
 602
 603 -- When parsing data declarations, we sometimes inadvertently parse
 604 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 605 -- This function splits up the type application, adds any pending
 606 -- arguments, and converts the type constructor back into a data constructor.
 607
 608 mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
 609
 610 mkPrefixCon ty tys
 611  = split ty tys
 612  where
 613    split (HsAppTy t u)  ts = split t (unbangedType u : ts)
 614    split (HsTyVar tc)   ts = tyConToDataCon tc  >>= \ data_con ->
 615                              return (data_con, PrefixCon ts)
 616    split _               _ = parseError "Illegal data/newtype declaration"
 617
 618 mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
 619 mkRecCon con fields
 620   = tyConToDataCon con  >>= \ data_con ->
 621     return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
 622
 623 tyConToDataCon :: RdrName -> P RdrName
 624 tyConToDataCon tc
 625   | isTcOcc (rdrNameOcc tc)
 626   = return (setRdrNameSpace tc srcDataName)
 627   | otherwise
 628   = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 629
 630 ----------------------------------------------------------------------------
 631 -- Various Syntactic Checks
 632
 633 checkInstType :: RdrNameHsType -> P RdrNameHsType
 634 checkInstType t
 635   = case t of
 636         HsForAllTy exp tvs ctxt ty ->
 637                 checkDictTy ty [] >>= \ dict_ty ->
 638                 return (HsForAllTy exp tvs ctxt dict_ty)
 639
 640         HsParTy ty -> checkInstType ty
 641
 642         ty ->   checkDictTy ty [] >>= \ dict_ty->
 643                 return (HsForAllTy Implicit [] [] dict_ty)
 644
 645 checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
 646 checkTyVars tvs
 647   = mapM chk tvs
 648   where
 649         --  Check that the name space is correct!
 650     chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = return (KindedTyVar tv k)
 651     chk (HsTyVar tv)               | isRdrTyVar tv = return (UserTyVar tv)
 652     chk other                      = parseError "Type found where type variable expected"
 653
 654 checkTyClHdr :: RdrNameContext -> RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
 655 -- The header of a type or class decl should look like
 656 --      (C a, D b) => T a b
 657 -- or   T a b
 658 -- or   a + b
 659 -- etc
 660 checkTyClHdr cxt ty
 661   = go ty []            >>= \ (tc, tvs) ->
 662     mapM chk_pred cxt   >>= \ _ ->
 663     return (cxt, tc, tvs)
 664   where
 665     go (HsTyVar tc)    acc
 666         | not (isRdrTyVar tc) = checkTyVars acc         >>= \ tvs ->
 667                                 return (tc, tvs)
 668     go (HsOpTy t1 tc t2) acc  = checkTyVars (t1:t2:acc) >>= \ tvs ->
 669                                 return (tc, tvs)
 670     go (HsParTy ty)    acc    = go ty acc
 671     go (HsAppTy t1 t2) acc    = go t1 (t2:acc)
 672     go other           acc    = parseError "Malformed LHS to type of class declaration"
 673
 674         -- The predicates in a type or class decl must all
 675         -- be HsClassPs.  They need not all be type variables,
 676         -- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
 677     chk_pred (HsClassP _ args) = return ()
 678     chk_pred pred              = parseError "Malformed context in type or class declaration"
 679
 680
 681 checkContext :: RdrNameHsType -> P RdrNameContext
 682 checkContext (HsTupleTy _ ts)   -- (Eq a, Ord b) shows up as a tuple type
 683   = mapM checkPred ts
 684
 685 checkContext (HsParTy ty)       -- to be sure HsParTy doesn't get into the way
 686   = checkContext ty
 687
 688 checkContext (HsTyVar t)        -- Empty context shows up as a unit type ()
 689   | t == getRdrName unitTyCon = return []
 690
 691 checkContext t
 692   = checkPred t >>= \p ->
 693     return [p]
 694
 695 checkPred :: RdrNameHsType -> P (HsPred RdrName)
 696 -- Watch out.. in ...deriving( Show )... we use checkPred on
 697 -- the list of partially applied predicates in the deriving,
 698 -- so there can be zero args.
 699 checkPred (HsPredTy (HsIParam n ty)) = return (HsIParam n ty)
 700 checkPred ty
 701   = go ty []
 702   where
 703     go (HsTyVar t) args   | not (isRdrTyVar t)
 704                           = return (HsClassP t args)
 705     go (HsAppTy l r) args = go l (r:args)
 706     go (HsParTy t)   args = go t args
 707     go _             _    = parseError "Illegal class assertion"
 708
 709 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 710 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 711         = return (mkHsDictTy t args)
 712 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 713 checkDictTy (HsParTy t)   args = checkDictTy t args
 714 checkDictTy _ _ = parseError "Malformed context in instance header"
 715
 716
 717 ---------------------------------------------------------------------------
 718 -- Checking statements in a do-expression
 719 --      We parse   do { e1 ; e2 ; }
 720 --      as [ExprStmt e1, ExprStmt e2]
 721 -- checkDo (a) checks that the last thing is an ExprStmt
 722 --         (b) transforms it to a ResultStmt
 723 -- same comments apply for mdo as well
 724
 725 checkDo  = checkDoMDo "a " "'do'"
 726 checkMDo = checkDoMDo "an " "'mdo'"
 727
 728 checkDoMDo _   nm []               = parseError $ "Empty " ++ nm ++ " construct"
 729 checkDoMDo _   _  [ExprStmt e _ l] = return [ResultStmt e l]
 730 checkDoMDo pre nm [s]              = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
 731 checkDoMDo pre nm (s:ss)           = checkDoMDo pre nm ss       >>= \ ss' ->
 732                                      return (s:ss')
 733
 734 -- -------------------------------------------------------------------------
 735 -- Checking Patterns.
 736
 737 -- We parse patterns as expressions and check for valid patterns below,
 738 -- converting the expression into a pattern at the same time.
 739
 740 checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
 741 checkPattern loc e = setSrcLocFor loc (checkPat e [])
 742
 743 checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
 744 checkPatterns loc es = mapM (checkPattern loc) es
 745
 746 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 747 checkPat (HsVar c) args | isRdrDataCon c = return (ConPatIn c (PrefixCon args))
 748 checkPat (HsApp f x) args =
 749         checkPat x [] >>= \x ->
 750         checkPat f (x:args)
 751 checkPat e [] = case e of
 752         EWildPat            -> return (WildPat placeHolderType)
 753         HsVar x | isQual x  -> parseError ("Qualified variable in pattern: " ++ showRdrName x)
 754                 | otherwise -> return (VarPat x)
 755         HsLit l             -> return (LitPat l)
 756
 757         -- Overloaded numeric patterns (e.g. f 0 x = x)
 758         -- Negation is recorded separately, so that the literal is zero or +ve
 759         -- NB. Negative *primitive* literals are already handled by
 760         --     RdrHsSyn.mkHsNegApp
 761         HsOverLit pos_lit            -> return (NPatIn pos_lit Nothing)
 762         NegApp (HsOverLit pos_lit) _ -> return (NPatIn pos_lit (Just placeHolderName))
 763
 764         ELazyPat e         -> checkPat e [] >>= (return . LazyPat)
 765         EAsPat n e         -> checkPat e [] >>= (return . AsPat n)
 766         ExprWithTySig e t  -> checkPat e [] >>= \e ->
 767                               -- Pattern signatures are parsed as sigtypes,
 768                               -- but they aren't explicit forall points.  Hence
 769                               -- we have to remove the implicit forall here.
 770                               let t' = case t of
 771                                           HsForAllTy Implicit _ [] ty -> ty
 772                                           other -> other
 773                               in
 774                               return (SigPatIn e t')
 775
 776         -- n+k patterns
 777         OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
 778                            | plus == plus_RDR
 779                            -> return (mkNPlusKPat n lit)
 780                            where
 781                               plus_RDR = mkUnqual varName FSLIT("+")    -- Hack
 782
 783         OpApp l op fix r   -> checkPat l [] >>= \l ->
 784                               checkPat r [] >>= \r ->
 785                               case op of
 786                                  HsVar c | isDataOcc (rdrNameOcc c)
 787                                         -> return (ConPatIn c (InfixCon l r))
 788                                  _ -> patFail
 789
 790         HsPar e            -> checkPat e [] >>= (return . ParPat)
 791         ExplicitList _ es  -> mapM (\e -> checkPat e []) es >>= \ps ->
 792                               return (ListPat ps placeHolderType)
 793         ExplicitPArr _ es  -> mapM (\e -> checkPat e []) es >>= \ps ->
 794                               return (PArrPat ps placeHolderType)
 795
 796         ExplicitTuple es b -> mapM (\e -> checkPat e []) es >>= \ps ->
 797                               return (TuplePat ps b)
 798
 799         RecordCon c fs     -> mapM checkPatField fs >>= \fs ->
 800                               return (ConPatIn c (RecCon fs))
 801 -- Generics
 802         HsType ty          -> return (TypePat ty)
 803         _                  -> patFail
 804
 805 checkPat _ _ = patFail
 806
 807 checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
 808 checkPatField (n,e) = checkPat e [] >>= \p ->
 809                       return (n,p)
 810
 811 patFail = parseError "Parse error in pattern"
 812
 813
 814 ---------------------------------------------------------------------------
 815 -- Check Equation Syntax
 816
 817 checkValDef
 818         :: RdrNameHsExpr
 819         -> Maybe RdrNameHsType
 820         -> RdrNameGRHSs
 821         -> SrcLoc
 822         -> P RdrBinding
 823
 824 checkValDef lhs opt_sig grhss loc
 825  = case isFunLhs lhs [] of
 826            Just (f,inf,es)
 827              | isQual f
 828              -> parseError ("Qualified name in function definition: "  ++ showRdrName f)
 829              | otherwise
 830              -> checkPatterns loc es >>= \ps ->
 831                 return (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
 832
 833            Nothing ->
 834                 checkPattern loc lhs >>= \lhs ->
 835                 return (RdrValBinding (PatMonoBind lhs grhss loc))
 836
 837 checkValSig
 838         :: RdrNameHsExpr
 839         -> RdrNameHsType
 840         -> SrcLoc
 841         -> P RdrBinding
 842 checkValSig (HsVar v) ty loc | isUnqual v = return (RdrHsDecl (SigD (Sig v ty loc)))
 843 checkValSig other     ty loc = parseError "Type signature given for an expression"
 844
 845 mkSigDecls :: [Sig RdrName] -> RdrBinding
 846 mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs]
 847
 848
 849 -- A variable binding is parsed as an RdrNameFunMonoBind.
 850 -- See comments with HsBinds.MonoBinds
 851
 852 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 853 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 854                                 = Just (op, True, (l:r:es))
 855                                         | otherwise
 856                                 = case isFunLhs l es of
 857                                     Just (op', True, j : k : es') ->
 858                                       Just (op', True, j : OpApp k (HsVar op) fix r : es')
 859                                     _ -> Nothing
 860 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 861                                 = Just (f,False,es)
 862 isFunLhs (HsApp f e) es         = isFunLhs f (e:es)
 863 isFunLhs (HsPar e)   es@(_:_)   = isFunLhs e es
 864 isFunLhs _ _                    = Nothing
 865
 866 ---------------------------------------------------------------------------
 867 -- Miscellaneous utilities
 868
 869 checkPrecP :: Int -> P Int
 870 checkPrecP i | 0 <= i && i <= maxPrecedence = return i
 871              | otherwise                    = parseError "Precedence out of range"
 872
 873 mkRecConstrOrUpdate
 874         :: RdrNameHsExpr
 875         -> RdrNameHsRecordBinds
 876         -> P RdrNameHsExpr
 877
 878 mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
 879   = return (RecordCon c fs)
 880 mkRecConstrOrUpdate exp fs@(_:_)
 881   = return (RecordUpd exp fs)
 882 mkRecConstrOrUpdate _ _
 883   = parseError "Empty record update"
 884
 885 -----------------------------------------------------------------------------
 886 -- utilities for foreign declarations
 887
 888 -- supported calling conventions
 889 --
 890 data CallConv = CCall  CCallConv        -- ccall or stdcall
 891               | DNCall                  -- .NET
 892
 893 -- construct a foreign import declaration
 894 --
 895 mkImport :: CallConv
 896          -> Safety
 897          -> (FastString, RdrName, RdrNameHsType)
 898          -> SrcLoc
 899          -> P RdrNameHsDecl
 900 mkImport (CCall  cconv) safety (entity, v, ty) loc =
 901   parseCImport entity cconv safety v                     >>= \importSpec ->
 902   return $ ForD (ForeignImport v ty importSpec                     False loc)
 903 mkImport (DNCall      ) _      (entity, v, ty) loc =
 904   parseDImport entity                                    >>= \ spec ->
 905   return $ ForD (ForeignImport v ty (DNImport spec) False loc)
 906
 907 -- parse the entity string of a foreign import declaration for the `ccall' or
 908 -- `stdcall' calling convention'
 909 --
 910 parseCImport :: FastString
 911              -> CCallConv
 912              -> Safety
 913              -> RdrName
 914              -> P ForeignImport
 915 parseCImport entity cconv safety v
 916   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 917   | entity == FSLIT ("dynamic") =
 918     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 919   | entity == FSLIT ("wrapper") =
 920     return $ CImport cconv safety nilFS nilFS CWrapper
 921   | otherwise                  = parse0 (unpackFS entity)
 922     where
 923       -- using the static keyword?
 924       parse0 (' ':                    rest) = parse0 rest
 925       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 926       parse0                          rest  = parse1 rest
 927       -- check for header file name
 928       parse1     ""               = parse4 ""    nilFS        False nilFS
 929       parse1     (' ':rest)       = parse1 rest
 930       parse1 str@('&':_   )       = parse2 str   nilFS
 931       parse1 str@('[':_   )       = parse3 str   nilFS        False
 932       parse1 str
 933         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 934         | otherwise               = parse4 str   nilFS        False nilFS
 935         where
 936           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 937       -- check for address operator (indicating a label import)
 938       parse2     ""         header = parse4 ""   header False nilFS
 939       parse2     (' ':rest) header = parse2 rest header
 940       parse2     ('&':rest) header = parse3 rest header True
 941       parse2 str@('[':_   ) header = parse3 str  header False
 942       parse2 str            header = parse4 str  header False nilFS
 943       -- check for library object name
 944       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 945       parse3 ('[':rest) header isLbl =
 946         case break (== ']') rest of
 947           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 948           _                         -> parseError "Missing ']' in entity"
 949       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 950       -- check for name of C function
 951       parse4 ""         header isLbl lib = build (mkExtName v) header isLbl lib
 952       parse4 (' ':rest) header isLbl lib = parse4 rest         header isLbl lib
 953       parse4 str        header isLbl lib
 954         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 955         | otherwise                      = parseError "Malformed entity string"
 956         where
 957           (first, rest) = break (== ' ') str
 958       --
 959       build cid header False lib = return $
 960         CImport cconv safety header lib (CFunction (StaticTarget cid))
 961       build cid header True  lib = return $
 962         CImport cconv safety header lib (CLabel                  cid )
 963
 964 --
 965 -- Unravel a dotnet spec string.
 966 --
 967 parseDImport :: FastString -> P DNCallSpec
 968 parseDImport entity = parse0 comps
 969  where
 970   comps = words (unpackFS entity)
 971
 972   parse0 [] = d'oh
 973   parse0 (x : xs)
 974     | x == "static" = parse1 True xs
 975     | otherwise     = parse1 False (x:xs)
 976
 977   parse1 _ [] = d'oh
 978   parse1 isStatic (x:xs)
 979     | x == "method" = parse2 isStatic DNMethod xs
 980     | x == "field"  = parse2 isStatic DNField xs
 981     | x == "ctor"   = parse2 isStatic DNConstructor xs
 982   parse1 isStatic xs = parse2 isStatic DNMethod xs
 983
 984   parse2 _ _ [] = d'oh
 985   parse2 isStatic kind (('[':x):xs) =
 986      case x of
 987         [] -> d'oh
 988         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
 989   parse2 isStatic kind xs = parse3 isStatic kind "" xs
 990
 991   parse3 isStatic kind assem [x] =
 992     return (DNCallSpec isStatic kind assem x
 993                           -- these will be filled in once known.
 994                         (error "FFI-dotnet-args")
 995                         (error "FFI-dotnet-result"))
 996   parse3 _ _ _ _ = d'oh
 997
 998   d'oh = parseError "Malformed entity string"
 999
1000 -- construct a foreign export declaration
1001 --
1002 mkExport :: CallConv
1003          -> (FastString, RdrName, RdrNameHsType)
1004          -> SrcLoc
1005          -> P RdrNameHsDecl
1006 mkExport (CCall  cconv) (entity, v, ty) loc = return $
1007   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
1008   where
1009     entity' | nullFastString entity = mkExtName v
1010             | otherwise             = entity
1011 mkExport DNCall (entity, v, ty) loc =
1012   parseError "Foreign export is not yet supported for .NET"
1013
1014 -- Supplying the ext_name in a foreign decl is optional; if it
1015 -- isn't there, the Haskell name is assumed. Note that no transformation
1016 -- of the Haskell name is then performed, so if you foreign export (++),
1017 -- it's external name will be "++". Too bad; it's important because we don't
1018 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1019 -- (This is why we use occNameUserString.)
1020 --
1021 mkExtName :: RdrName -> CLabelString
1022 mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
1023 \end{code}
1024
1025
1026 -----------------------------------------------------------------------------
1027 -- Misc utils
1028
1029 \begin{code}
1030 showRdrName :: RdrName -> String
1031 showRdrName r = showSDoc (ppr r)
1032
1033 parseError :: String -> P a
1034 parseError s =
1035   getSrcLoc >>= \ loc ->
1036   failLocMsgP loc loc s
1037 \end{code}