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