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