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