ghc/compiler/parser/RdrHsSyn.lhs

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