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