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, mkInlineSpec,
  15         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
  16
  17         cvBindGroup,
  18         cvBindsAndSigs,
  19         cvTopDecls,
  20         findSplice, mkGroup,
  21
  22         -- Stuff to do with Foreign declarations
  23         CallConv(..),
  24         mkImport,            -- CallConv -> Safety
  25                               -- -> (FastString, RdrName, RdrNameHsType)
  26                               -- -> P RdrNameHsDecl
  27         mkExport,            -- CallConv
  28                               -- -> (FastString, RdrName, RdrNameHsType)
  29                               -- -> P RdrNameHsDecl
  30         mkExtName,           -- RdrName -> CLabelString
  31         mkGadtDecl,          -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
  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,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
  39         checkTyVars,          -- [LHsType RdrName] -> P ()
  40         checkSynHdr,          -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
  41         checkKindSigs,        -- [LTyClDecl RdrName] -> P ()
  42         checkInstType,        -- HsType -> P HsType
  43         checkDerivDecl,       -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
  44         checkPattern,         -- HsExp -> P HsPat
  45         bang_RDR,
  46         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
  47         checkDo,              -- [Stmt] -> P [Stmt]
  48         checkMDo,             -- [Stmt] -> P [Stmt]
  49         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  50         checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  51         parseError,           -- String -> Pa
  52     ) where
  53
  54 #include "HsVersions.h"
  55
  56 import HsSyn            -- Lots of it
  57 import RdrName          ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
  58                           isRdrDataCon, isUnqual, getRdrName, isQual,
  59                           setRdrNameSpace )
  60 import BasicTypes       ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
  61 import Lexer            ( P, failSpanMsgP, extension, glaExtsEnabled, bangPatEnabled )
  62 import TysWiredIn       ( unitTyCon )
  63 import ForeignCall      ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
  64                           DNCallSpec(..), DNKind(..), CLabelString )
  65 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
  66                           occNameString )
  67 import SrcLoc
  68 import OrdList          ( OrdList, fromOL )
  69 import Bag              ( Bag, emptyBag, snocBag, consBag, foldrBag )
  70 import Outputable
  71 import FastString
  72 import Panic
  73
  74 import List             ( isSuffixOf, nubBy )
  75 import Monad            ( unless )
  76 \end{code}
  77
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 \subsection{A few functions over HsSyn at RdrName}
  82 %*                                                                    *
  83 %************************************************************************
  84
  85 extractHsTyRdrNames finds the free variables of a HsType
  86 It's used when making the for-alls explicit.
  87
  88 \begin{code}
  89 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
  90 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
  91
  92 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
  93 -- This one takes the context and tau-part of a
  94 -- sigma type and returns their free type variables
  95 extractHsRhoRdrTyVars ctxt ty
  96  = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
  97
  98 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
  99
 100 extract_pred (HsClassP cls tys) acc     = foldr extract_lty acc tys
 101 extract_pred (HsIParam n ty) acc        = extract_lty ty acc
 102
 103 extract_lty (L loc ty) acc
 104   = case ty of
 105       HsTyVar tv                -> extract_tv loc tv acc
 106       HsBangTy _ ty             -> extract_lty ty acc
 107       HsAppTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
 108       HsListTy ty               -> extract_lty ty acc
 109       HsPArrTy ty               -> extract_lty ty acc
 110       HsTupleTy _ tys           -> foldr extract_lty acc tys
 111       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
 112       HsPredTy p                -> extract_pred p acc
 113       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
 114       HsParTy ty                -> extract_lty ty acc
 115       HsNumTy num               -> acc
 116       HsSpliceTy _              -> acc  -- Type splices mention no type variables
 117       HsKindSig ty k            -> extract_lty ty acc
 118       HsForAllTy exp [] cx ty   -> extract_lctxt cx (extract_lty ty acc)
 119       HsForAllTy exp tvs cx ty  -> acc ++ (filter ((`notElem` locals) . unLoc) $
 120                                            extract_lctxt cx (extract_lty ty []))
 121                                 where
 122                                    locals = hsLTyVarNames tvs
 123       HsDocTy ty doc            -> extract_lty ty acc
 124
 125 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
 126 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
 127                       | otherwise     = acc
 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 { fun_matches = 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 ats docs
 161   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
 162                 tcdFDs = fds,
 163                 tcdSigs = sigs,
 164                 tcdMeths = mbinds,
 165                 tcdATs   = ats,
 166                 tcdDocs  = docs
 167                 }
 168
 169 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
 170   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
 171              tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
 172              tcdKindSig = ksig, tcdDerivs = maybe_deriv }
 173 \end{code}
 174
 175 \begin{code}
 176 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
 177 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
 178 -- can't take an unboxed arg.  But that is exactly what it will see when
 179 -- we write "-3#".  So we have to do the negation right now!
 180 mkHsNegApp (L loc e) = f e
 181   where f (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 182         f (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 183         f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 184         f expr                     = NegApp (L loc e) noSyntaxExpr
 185 \end{code}
 186
 187 %************************************************************************
 188 %*                                                                      *
 189 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
 190 %*                                                                      *
 191 %************************************************************************
 192
 193 Function definitions are restructured here. Each is assumed to be recursive
 194 initially, and non recursive definitions are discovered by the dependency
 195 analyser.
 196
 197
 198 \begin{code}
 199 --  | Groups together bindings for a single function
 200 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
 201 cvTopDecls decls = go (fromOL decls)
 202   where
 203     go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
 204     go []                   = []
 205     go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
 206                             where (L l' b', ds') = getMonoBind (L l b) ds
 207     go (d : ds)             = d : go ds
 208
 209 -- Declaration list may only contain value bindings and signatures.
 210 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 211 cvBindGroup binding
 212   = case cvBindsAndSigs binding of
 213       (mbs, sigs, [], _) ->                 -- list of type decls *always* empty
 214         ValBindsIn mbs sigs
 215
 216 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
 217   -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName])
 218 -- Input decls contain just value bindings and signatures
 219 -- and in case of class or instance declarations also
 220 -- associated type declarations. They might also contain Haddock comments.
 221 cvBindsAndSigs  fb = go (fromOL fb)
 222   where
 223     go []                  = (emptyBag, [], [], [])
 224     go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs)
 225                             where (bs, ss, ts, docs) = go ds
 226     go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, add_doc x docs)
 227                             where (b', ds')    = getMonoBind (L l b) ds
 228                                   (bs, ss, ts, docs) = go ds'
 229     go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
 230                             where (bs, ss, ts, docs) = go ds
 231     go (L _ (DocD d) : ds)     =  (bs, ss, ts, DocEntity d : docs)
 232                             where (bs, ss, ts, docs) = go ds
 233
 234 -----------------------------------------------------------------------------
 235 -- Group function bindings into equation groups
 236
 237 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 238   -> (LHsBind RdrName, [LHsDecl RdrName])
 239 -- Suppose      (b',ds') = getMonoBind b ds
 240 --      ds is a list of parsed bindings
 241 --      b is a MonoBinds that has just been read off the front
 242
 243 -- Then b' is the result of grouping more equations from ds that
 244 -- belong with b into a single MonoBinds, and ds' is the depleted
 245 -- list of parsed bindings.
 246 --
 247 -- All Haddock comments between equations inside the group are
 248 -- discarded.
 249 --
 250 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 251
 252 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
 253                                    fun_matches = MatchGroup mtchs1 _ })) binds
 254   | has_args mtchs1
 255   = go is_infix1 mtchs1 loc1 binds []
 256   where
 257     go is_infix mtchs loc
 258        (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
 259                                 fun_matches = MatchGroup mtchs2 _ })) : binds) _
 260         | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
 261                         (combineSrcSpans loc loc2) binds []
 262     go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
 263         = let doc_decls' = doc_decl : doc_decls
 264           in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
 265     go is_infix mtchs loc binds doc_decls
 266         = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
 267         -- Reverse the final matches, to get it back in the right order
 268         -- Do the same thing with the trailing doc comments
 269
 270 getMonoBind bind binds = (bind, binds)
 271
 272 has_args ((L _ (Match args _ _)) : _) = not (null args)
 273         -- Don't group together FunBinds if they have
 274         -- no arguments.  This is necessary now that variable bindings
 275         -- with no arguments are now treated as FunBinds rather
 276         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 277 \end{code}
 278
 279 \begin{code}
 280 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 281 findSplice ds = addl emptyRdrGroup ds
 282
 283 mkGroup :: [LHsDecl a] -> HsGroup a
 284 mkGroup ds = addImpDecls emptyRdrGroup ds
 285
 286 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
 287 -- The decls are imported, and should not have a splice
 288 addImpDecls group decls = case addl group decls of
 289                                 (group', Nothing) -> group'
 290                                 other             -> panic "addImpDecls"
 291
 292 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 293         -- This stuff reverses the declarations (again) but it doesn't matter
 294
 295 -- Base cases
 296 addl gp []           = (gp, Nothing)
 297 addl gp (L l d : ds) = add gp l d ds
 298
 299
 300 add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
 301   -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 302
 303 add gp l (SpliceD e) ds = (gp, Just (e, ds))
 304
 305 -- Class declarations: pull out the fixity signatures to the top
 306 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs})
 307     l decl@(TyClD d) ds
 308         | isClassDecl d =
 309                 let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
 310                 addl (gp { hs_tyclds = L l d : ts,
 311                            hs_fixds = fsigs ++ fs,
 312                            hs_docs = add_doc decl docs}) ds
 313         | isIdxTyDecl d =
 314                 addl (gp { hs_tyclds = L l d : ts }) ds
 315         | otherwise =
 316                 addl (gp { hs_tyclds = L l d : ts,
 317                            hs_docs = add_doc decl docs }) ds
 318
 319 -- Signatures: fixity sigs go a different place than all others
 320 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
 321   = addl (gp {hs_fixds = L l f : ts}) ds
 322 add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(SigD d) ds
 323   = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) ds
 324
 325 -- Value declarations: use add_bind
 326 add gp@(HsGroup {hs_valds  = ts, hs_docs = docs}) l x@(ValD d) ds
 327   = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds
 328
 329 -- The rest are routine
 330 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
 331   = addl (gp { hs_instds = L l d : ts }) ds
 332 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
 333   = addl (gp { hs_derivds = L l d : ts }) ds
 334 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
 335   = addl (gp { hs_defds = L l d : ts }) ds
 336 add gp@(HsGroup {hs_fords  = ts, hs_docs = docs}) l x@(ForD d) ds
 337   = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) ds
 338 add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
 339   = addl (gp { hs_depds = L l d : ts }) ds
 340 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
 341   = addl (gp { hs_ruleds = L l d : ts }) ds
 342
 343 add gp l (DocD d) ds
 344   = addl (gp { hs_docs = DocEntity d : (hs_docs gp) })  ds
 345
 346 add_doc decl docs = case getMainDeclBinder decl of
 347   Just name -> DeclEntity name : docs
 348   Nothing   -> docs
 349
 350 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 351 add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs               (s:sigs)
 352 \end{code}
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsection[PrefixToHS-utils]{Utilities for conversion}
 357 %*                                                                      *
 358 %************************************************************************
 359
 360
 361 \begin{code}
 362 -----------------------------------------------------------------------------
 363 -- mkPrefixCon
 364
 365 -- When parsing data declarations, we sometimes inadvertently parse
 366 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 367 -- This function splits up the type application, adds any pending
 368 -- arguments, and converts the type constructor back into a data constructor.
 369
 370 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
 371   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 372 mkPrefixCon ty tys
 373  = split ty tys
 374  where
 375    split (L _ (HsAppTy t u)) ts = split t (u : ts)
 376    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
 377                                      return (data_con, PrefixCon ts)
 378    split (L l _) _              = parseError l "parse error in data/newtype declaration"
 379
 380 mkRecCon :: Located RdrName ->
 381             [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
 382             P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 383 mkRecCon (L loc con) fields
 384   = do data_con <- tyConToDataCon loc con
 385        return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
 386
 387 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 388 tyConToDataCon loc tc
 389   | isTcOcc (rdrNameOcc tc)
 390   = return (L loc (setRdrNameSpace tc srcDataName))
 391   | otherwise
 392   = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 393
 394 ----------------------------------------------------------------------------
 395 -- Various Syntactic Checks
 396
 397 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
 398 checkInstType (L l t)
 399   = case t of
 400         HsForAllTy exp tvs ctxt ty -> do
 401                 dict_ty <- checkDictTy ty
 402                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
 403
 404         HsParTy ty -> checkInstType ty
 405
 406         ty ->   do dict_ty <- checkDictTy (L l ty)
 407                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 408
 409 -- Check whether the given list of type parameters are all type variables
 410 -- (possibly with a kind signature).  If the second argument is `False',
 411 -- only type variables are allowed and we raise an error on encountering a
 412 -- non-variable; otherwise, we allow non-variable arguments and return the
 413 -- entire list of parameters.
 414 --
 415 checkTyVars :: [LHsType RdrName] -> P ()
 416 checkTyVars tparms = mapM_ chk tparms
 417   where
 418         -- Check that the name space is correct!
 419     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 420         | isRdrTyVar tv    = return ()
 421     chk (L l (HsTyVar tv))
 422         | isRdrTyVar tv    = return ()
 423     chk (L l other)        =
 424           parseError l "Type found where type variable expected"
 425
 426 -- Check whether the type arguments in a type synonym head are simply
 427 -- variables.  If not, we have a type equation of a type function and return
 428 -- all patterns.  If yes, we return 'Nothing' as the third component to
 429 -- indicate a vanilla type synonym.
 430 --
 431 checkSynHdr :: LHsType RdrName
 432             -> Bool                             -- is type instance?
 433             -> P (Located RdrName,              -- head symbol
 434                   [LHsTyVarBndr RdrName],       -- parameters
 435                   [LHsType RdrName])            -- type patterns
 436 checkSynHdr ty isTyInst =
 437   do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
 438      ; unless isTyInst $ checkTyVars tparms
 439      ; return (tc, tvs, tparms) }
 440
 441
 442 -- Well-formedness check and decomposition of type and class heads.
 443 --
 444 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 445   -> P (LHsContext RdrName,          -- the type context
 446         Located RdrName,             -- the head symbol (type or class name)
 447         [LHsTyVarBndr RdrName],      -- free variables of the non-context part
 448         [LHsType RdrName])           -- parameters of head symbol
 449 -- The header of a type or class decl should look like
 450 --      (C a, D b) => T a b
 451 -- or   T a b
 452 -- or   a + b
 453 -- etc
 454 -- With associated types, we can also have non-variable parameters; ie,
 455 --      T Int [a]
 456 -- The unaltered parameter list is returned in the fourth component of the
 457 -- result.  Eg, for
 458 --      T Int [a]
 459 -- we return
 460 --      ('()', 'T', ['a'], ['Int', '[a]'])
 461 checkTyClHdr (L l cxt) ty
 462   = do (tc, tvs, parms) <- gol ty []
 463        mapM_ chk_pred cxt
 464        return (L l cxt, tc, tvs, parms)
 465   where
 466     gol (L l ty) acc = go l ty acc
 467
 468     go l (HsTyVar tc)    acc
 469         | not (isRdrTyVar tc)   = do
 470                                     tvs <- extractTyVars acc
 471                                     return (L l tc, tvs, acc)
 472     go l (HsOpTy t1 tc t2) acc  = do
 473                                     tvs <- extractTyVars (t1:t2:acc)
 474                                     return (tc, tvs, acc)
 475     go l (HsParTy ty)    acc    = gol ty acc
 476     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
 477     go l other           acc    =
 478       parseError l "Malformed head of type or class declaration"
 479
 480         -- The predicates in a type or class decl must all
 481         -- be HsClassPs.  They need not all be type variables,
 482         -- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
 483     chk_pred (L l (HsClassP _ args)) = return ()
 484     chk_pred (L l _)
 485        = parseError l "Malformed context in type or class declaration"
 486
 487 -- Extract the type variables of a list of type parameters.
 488 --
 489 -- * Type arguments can be complex type terms (needed for associated type
 490 --   declarations).
 491 --
 492 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 493 extractTyVars tvs = collects [] tvs
 494   where
 495         -- Collect all variables (1st arg serves as an accumulator)
 496     collect tvs (L l (HsForAllTy _ _ _ _)) =
 497       parseError l "Forall type not allowed as type parameter"
 498     collect tvs (L l (HsTyVar tv))
 499       | isRdrTyVar tv                      = return $ L l (UserTyVar tv) : tvs
 500       | otherwise                          = return tvs
 501     collect tvs (L l (HsBangTy _ _      )) =
 502       parseError l "Bang-style type annotations not allowed as type parameter"
 503     collect tvs (L l (HsAppTy t1 t2     )) = do
 504                                                tvs' <- collect tvs t2
 505                                                collect tvs' t1
 506     collect tvs (L l (HsFunTy t1 t2     )) = do
 507                                                tvs' <- collect tvs t2
 508                                                collect tvs' t1
 509     collect tvs (L l (HsListTy t        )) = collect tvs t
 510     collect tvs (L l (HsPArrTy t        )) = collect tvs t
 511     collect tvs (L l (HsTupleTy _ ts    )) = collects tvs ts
 512     collect tvs (L l (HsOpTy t1 _ t2    )) = do
 513                                                tvs' <- collect tvs t2
 514                                                collect tvs' t1
 515     collect tvs (L l (HsParTy t         )) = collect tvs t
 516     collect tvs (L l (HsNumTy t         )) = return tvs
 517     collect tvs (L l (HsPredTy t        )) =
 518       parseError l "Predicate not allowed as type parameter"
 519     collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
 520         | isRdrTyVar tv                    =
 521           return $ L l (KindedTyVar tv k) : tvs
 522         | otherwise                        =
 523           parseError l "Kind signature only allowed for type variables"
 524     collect tvs (L l (HsSpliceTy t      )) =
 525       parseError l "Splice not allowed as type parameter"
 526
 527         -- Collect all variables of a list of types
 528     collects tvs []     = return tvs
 529     collects tvs (t:ts) = do
 530                             tvs' <- collects tvs ts
 531                             collect tvs' t
 532
 533 -- Check that associated type declarations of a class are all kind signatures.
 534 --
 535 checkKindSigs :: [LTyClDecl RdrName] -> P ()
 536 checkKindSigs = mapM_ check
 537   where
 538     check (L l tydecl)
 539       | isKindSigDecl tydecl
 540         || isSynDecl tydecl  = return ()
 541       | otherwise            =
 542         parseError l "Type declaration in a class must be a kind signature or synonym default"
 543
 544 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 545 checkContext (L l t)
 546   = check t
 547  where
 548   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 549     = do ctx <- mapM checkPred ts
 550          return (L l ctx)
 551
 552   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 553     = check (unLoc ty)
 554
 555   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 556     | t == getRdrName unitTyCon = return (L l [])
 557
 558   check t
 559     = do p <- checkPred (L l t)
 560          return (L l [p])
 561
 562
 563 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 564 -- Watch out.. in ...deriving( Show )... we use checkPred on
 565 -- the list of partially applied predicates in the deriving,
 566 -- so there can be zero args.
 567 checkPred (L spn (HsPredTy (HsIParam n ty)))
 568   = return (L spn (HsIParam n ty))
 569 checkPred (L spn ty)
 570   = check spn ty []
 571   where
 572     checkl (L l ty) args = check l ty args
 573
 574     check _loc (HsTyVar t)             args | not (isRdrTyVar t)
 575                                             = return (L spn (HsClassP t args))
 576     check _loc (HsAppTy l r)           args = checkl l (r:args)
 577     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
 578     check _loc (HsParTy t)             args = checkl t args
 579     check loc _                        _    = parseError loc  "malformed class assertion"
 580
 581 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 582 checkDictTy (L spn ty) = check ty []
 583   where
 584   check (HsTyVar t) args | not (isRdrTyVar t)
 585         = return (L spn (HsPredTy (HsClassP t args)))
 586   check (HsAppTy l r) args = check (unLoc l) (r:args)
 587   check (HsParTy t)   args = check (unLoc t) args
 588   check _ _ = parseError spn "Malformed context in instance header"
 589
 590
 591 ---------------------------------------------------------------------------
 592 -- Checking stand-alone deriving declarations
 593
 594 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
 595 checkDerivDecl d@(L loc _) =
 596     do glaExtOn <- extension glaExtsEnabled
 597        if glaExtOn then return d
 598          else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
 599
 600 ---------------------------------------------------------------------------
 601 -- Checking statements in a do-expression
 602 --      We parse   do { e1 ; e2 ; }
 603 --      as [ExprStmt e1, ExprStmt e2]
 604 -- checkDo (a) checks that the last thing is an ExprStmt
 605 --         (b) returns it separately
 606 -- same comments apply for mdo as well
 607
 608 checkDo  = checkDoMDo "a " "'do'"
 609 checkMDo = checkDoMDo "an " "'mdo'"
 610
 611 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 612 checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 613 checkDoMDo pre nm loc ss   = do
 614   check ss
 615   where
 616         check  [L l (ExprStmt e _ _)] = return ([], e)
 617         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 618                                          " construct must be an expression")
 619         check (s:ss) = do
 620           (ss',e') <-  check ss
 621           return ((s:ss'),e')
 622
 623 -- -------------------------------------------------------------------------
 624 -- Checking Patterns.
 625
 626 -- We parse patterns as expressions and check for valid patterns below,
 627 -- converting the expression into a pattern at the same time.
 628
 629 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 630 checkPattern e = checkLPat e
 631
 632 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 633 checkPatterns es = mapM checkPattern es
 634
 635 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 636 checkLPat e@(L l _) = checkPat l e []
 637
 638 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 639 checkPat loc (L l (HsVar c)) args
 640   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 641 checkPat loc e args     -- OK to let this happen even if bang-patterns
 642                         -- are not enabled, because there is no valid
 643                         -- non-bang-pattern parse of (C ! e)
 644   | Just (e', args') <- splitBang e
 645   = do  { args'' <- checkPatterns args'
 646         ; checkPat loc e' (args'' ++ args) }
 647 checkPat loc (L _ (HsApp f x)) args
 648   = do { x <- checkLPat x; checkPat loc f (x:args) }
 649 checkPat loc (L _ e) []
 650   = do { p <- checkAPat loc e; return (L loc p) }
 651 checkPat loc pat _some_args
 652   = patFail loc
 653
 654 checkAPat loc e = case e of
 655    EWildPat            -> return (WildPat placeHolderType)
 656    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 657                                          ++ showRdrName x)
 658            | otherwise -> return (VarPat x)
 659    HsLit l             -> return (LitPat l)
 660
 661    -- Overloaded numeric patterns (e.g. f 0 x = x)
 662    -- Negation is recorded separately, so that the literal is zero or +ve
 663    -- NB. Negative *primitive* literals are already handled by
 664    --     RdrHsSyn.mkHsNegApp
 665    HsOverLit pos_lit            -> return (mkNPat pos_lit Nothing)
 666    NegApp (L _ (HsOverLit pos_lit)) _
 667                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
 668
 669    SectionR (L _ (HsVar bang)) e        -- (! x)
 670         | bang == bang_RDR
 671         -> do { bang_on <- extension bangPatEnabled
 672               ; if bang_on then checkLPat e >>= (return . BangPat)
 673                 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
 674
 675    ELazyPat e         -> checkLPat e >>= (return . LazyPat)
 676    EAsPat n e         -> checkLPat e >>= (return . AsPat n)
 677    ExprWithTySig e t  -> checkLPat e >>= \e ->
 678                          -- Pattern signatures are parsed as sigtypes,
 679                          -- but they aren't explicit forall points.  Hence
 680                          -- we have to remove the implicit forall here.
 681                          let t' = case t of
 682                                      L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 683                                      other -> other
 684                          in
 685                          return (SigPatIn e t')
 686
 687    -- n+k patterns
 688    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 689         (L _ (HsOverLit lit@(HsIntegral _ _)))
 690                       | plus == plus_RDR
 691                       -> return (mkNPlusKPat (L nloc n) lit)
 692
 693    OpApp l op fix r   -> checkLPat l >>= \l ->
 694                          checkLPat r >>= \r ->
 695                          case op of
 696                             L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 697                                    -> return (ConPatIn (L cl c) (InfixCon l r))
 698                             _ -> patFail loc
 699
 700    HsPar e                 -> checkLPat e >>= (return . ParPat)
 701    ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 702                          return (ListPat ps placeHolderType)
 703    ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 704                          return (PArrPat ps placeHolderType)
 705
 706    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
 707                          return (TuplePat ps b placeHolderType)
 708
 709    RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
 710                          return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
 711 -- Generics
 712    HsType ty          -> return (TypePat ty)
 713    _                  -> patFail loc
 714
 715 plus_RDR, bang_RDR :: RdrName
 716 plus_RDR = mkUnqual varName FSLIT("+")  -- Hack
 717 bang_RDR = mkUnqual varName FSLIT("!")  -- Hack
 718
 719 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
 720 checkPatField (n,e) = do
 721   p <- checkLPat e
 722   return (n,p)
 723
 724 patFail loc = parseError loc "Parse error in pattern"
 725
 726
 727 ---------------------------------------------------------------------------
 728 -- Check Equation Syntax
 729
 730 checkValDef :: LHsExpr RdrName
 731             -> Maybe (LHsType RdrName)
 732             -> Located (GRHSs RdrName)
 733             -> P (HsBind RdrName)
 734
 735 checkValDef lhs (Just sig) grhss
 736         -- x :: ty = rhs  parses as a *pattern* binding
 737   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 738
 739 checkValDef lhs opt_sig grhss
 740   = do  { mb_fun <- isFunLhs lhs
 741         ; case mb_fun of
 742             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
 743                                                 fun is_infix pats opt_sig grhss
 744             Nothing -> checkPatBind lhs grhss }
 745
 746 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 747   | isQual (unLoc fun)
 748   = parseError (getLoc fun) ("Qualified name in function definition: "  ++
 749                              showRdrName (unLoc fun))
 750   | otherwise
 751   = do  ps <- checkPatterns pats
 752         let match_span = combineSrcSpans lhs_loc rhs_span
 753         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 754         -- The span of the match covers the entire equation.
 755         -- That isn't quite right, but it'll do for now.
 756
 757 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 758 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 759 makeFunBind fn is_infix ms
 760   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
 761               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 762
 763 checkPatBind lhs (L _ grhss)
 764   = do  { lhs <- checkPattern lhs
 765         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 766
 767 checkValSig
 768         :: LHsExpr RdrName
 769         -> LHsType RdrName
 770         -> P (Sig RdrName)
 771 checkValSig (L l (HsVar v)) ty
 772   | isUnqual v && not (isDataOcc (rdrNameOcc v))
 773   = return (TypeSig (L l v) ty)
 774 checkValSig (L l other)     ty
 775   = parseError l "Invalid type signature"
 776
 777 mkGadtDecl :: Located RdrName
 778            -> LHsType RdrName -- assuming HsType
 779            -> ConDecl RdrName
 780 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
 781 mkGadtDecl name ty                                = mk_gadt_con name [] (noLoc []) ty
 782
 783 mk_gadt_con name qvars cxt ty
 784   = ConDecl { con_name     = name
 785             , con_explicit = Implicit
 786             , con_qvars    = qvars
 787             , con_cxt      = cxt
 788             , con_details  = PrefixCon []
 789             , con_res      = ResTyGADT ty
 790             , con_doc      = Nothing }
 791   -- NB: we put the whole constr type into the ResTyGADT for now;
 792   -- the renamer will unravel it once it has sorted out
 793   -- operator fixities
 794
 795 -- A variable binding is parsed as a FunBind.
 796
 797
 798         -- The parser left-associates, so there should
 799         -- not be any OpApps inside the e's
 800 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 801 -- Splits (f ! g a b) into (f, [(! g), a, g])
 802 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
 803   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 804   where
 805     (arg1,argns) = split_bang r_arg []
 806     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 807     split_bang e                 es = (e,es)
 808 splitBang other = Nothing
 809
 810 isFunLhs :: LHsExpr RdrName
 811          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 812 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 813 isFunLhs e = go e []
 814  where
 815    go (L loc (HsVar f)) es
 816         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
 817    go (L _ (HsApp f e)) es       = go f (e:es)
 818    go (L _ (HsPar e))   es@(_:_) = go e es
 819
 820         -- For infix function defns, there should be only one infix *function*
 821         -- (though there may be infix *datacons* involved too).  So we don't
 822         -- need fixity info to figure out which function is being defined.
 823         --      a `K1` b `op` c `K2` d
 824         -- must parse as
 825         --      (a `K1` b) `op` (c `K2` d)
 826         -- The renamer checks later that the precedences would yield such a parse.
 827         --
 828         -- There is a complication to deal with bang patterns.
 829         --
 830         -- ToDo: what about this?
 831         --              x + 1 `op` y = ...
 832
 833    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 834         | Just (e',es') <- splitBang e
 835         = do { bang_on <- extension bangPatEnabled
 836              ; if bang_on then go e' (es' ++ es)
 837                else return (Just (L loc' op, True, (l:r:es))) }
 838                 -- No bangs; behave just like the next case
 839         | not (isRdrDataCon op)         -- We have found the function!
 840         = return (Just (L loc' op, True, (l:r:es)))
 841         | otherwise                     -- Infix data con; keep going
 842         = do { mb_l <- go l es
 843              ; case mb_l of
 844                  Just (op', True, j : k : es')
 845                     -> return (Just (op', True, j : op_app : es'))
 846                     where
 847                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
 848                  _ -> return Nothing }
 849    go _ _ = return Nothing
 850
 851 ---------------------------------------------------------------------------
 852 -- Miscellaneous utilities
 853
 854 checkPrecP :: Located Int -> P Int
 855 checkPrecP (L l i)
 856  | 0 <= i && i <= maxPrecedence = return i
 857  | otherwise                    = parseError l "Precedence out of range"
 858
 859 mkRecConstrOrUpdate
 860         :: LHsExpr RdrName
 861         -> SrcSpan
 862         -> HsRecordBinds RdrName
 863         -> P (HsExpr RdrName)
 864
 865 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
 866   = return (RecordCon (L l c) noPostTcExpr fs)
 867 mkRecConstrOrUpdate exp loc fs@(_:_)
 868   = return (RecordUpd exp fs placeHolderType placeHolderType)
 869 mkRecConstrOrUpdate _ loc []
 870   = parseError loc "Empty record update"
 871
 872 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
 873 -- The Maybe is becuase the user can omit the activation spec (and usually does)
 874 mkInlineSpec Nothing    True  = alwaysInlineSpec        -- INLINE
 875 mkInlineSpec Nothing    False = neverInlineSpec         -- NOINLINE
 876 mkInlineSpec (Just act) inl   = Inline act inl
 877
 878
 879 -----------------------------------------------------------------------------
 880 -- utilities for foreign declarations
 881
 882 -- supported calling conventions
 883 --
 884 data CallConv = CCall  CCallConv        -- ccall or stdcall
 885               | DNCall                  -- .NET
 886
 887 -- construct a foreign import declaration
 888 --
 889 mkImport :: CallConv
 890          -> Safety
 891          -> (Located FastString, Located RdrName, LHsType RdrName)
 892          -> P (HsDecl RdrName)
 893 mkImport (CCall  cconv) safety (entity, v, ty) = do
 894   importSpec <- parseCImport entity cconv safety v
 895   return (ForD (ForeignImport v ty importSpec))
 896 mkImport (DNCall      ) _      (entity, v, ty) = do
 897   spec <- parseDImport entity
 898   return $ ForD (ForeignImport v ty (DNImport spec))
 899
 900 -- parse the entity string of a foreign import declaration for the `ccall' or
 901 -- `stdcall' calling convention'
 902 --
 903 parseCImport :: Located FastString
 904              -> CCallConv
 905              -> Safety
 906              -> Located RdrName
 907              -> P ForeignImport
 908 parseCImport (L loc entity) cconv safety v
 909   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 910   | entity == FSLIT ("dynamic") =
 911     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 912   | entity == FSLIT ("wrapper") =
 913     return $ CImport cconv safety nilFS nilFS CWrapper
 914   | otherwise                  = parse0 (unpackFS entity)
 915     where
 916       -- using the static keyword?
 917       parse0 (' ':                    rest) = parse0 rest
 918       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 919       parse0                          rest  = parse1 rest
 920       -- check for header file name
 921       parse1     ""               = parse4 ""    nilFS        False nilFS
 922       parse1     (' ':rest)       = parse1 rest
 923       parse1 str@('&':_   )       = parse2 str   nilFS
 924       parse1 str@('[':_   )       = parse3 str   nilFS        False
 925       parse1 str
 926         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 927         | otherwise               = parse4 str   nilFS        False nilFS
 928         where
 929           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 930       -- check for address operator (indicating a label import)
 931       parse2     ""         header = parse4 ""   header False nilFS
 932       parse2     (' ':rest) header = parse2 rest header
 933       parse2     ('&':rest) header = parse3 rest header True
 934       parse2 str@('[':_   ) header = parse3 str  header False
 935       parse2 str            header = parse4 str  header False nilFS
 936       -- check for library object name
 937       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 938       parse3 ('[':rest) header isLbl =
 939         case break (== ']') rest of
 940           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 941           _                         -> parseError loc "Missing ']' in entity"
 942       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 943       -- check for name of C function
 944       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
 945       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
 946       parse4 str        header isLbl lib
 947         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 948         | otherwise                      = parseError loc "Malformed entity string"
 949         where
 950           (first, rest) = break (== ' ') str
 951       --
 952       build cid header False lib = return $
 953         CImport cconv safety header lib (CFunction (StaticTarget cid))
 954       build cid header True  lib = return $
 955         CImport cconv safety header lib (CLabel                  cid )
 956
 957 --
 958 -- Unravel a dotnet spec string.
 959 --
 960 parseDImport :: Located FastString -> P DNCallSpec
 961 parseDImport (L loc entity) = parse0 comps
 962  where
 963   comps = words (unpackFS entity)
 964
 965   parse0 [] = d'oh
 966   parse0 (x : xs)
 967     | x == "static" = parse1 True xs
 968     | otherwise     = parse1 False (x:xs)
 969
 970   parse1 _ [] = d'oh
 971   parse1 isStatic (x:xs)
 972     | x == "method" = parse2 isStatic DNMethod xs
 973     | x == "field"  = parse2 isStatic DNField xs
 974     | x == "ctor"   = parse2 isStatic DNConstructor xs
 975   parse1 isStatic xs = parse2 isStatic DNMethod xs
 976
 977   parse2 _ _ [] = d'oh
 978   parse2 isStatic kind (('[':x):xs) =
 979      case x of
 980         [] -> d'oh
 981         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
 982   parse2 isStatic kind xs = parse3 isStatic kind "" xs
 983
 984   parse3 isStatic kind assem [x] =
 985     return (DNCallSpec isStatic kind assem x
 986                           -- these will be filled in once known.
 987                         (error "FFI-dotnet-args")
 988                         (error "FFI-dotnet-result"))
 989   parse3 _ _ _ _ = d'oh
 990
 991   d'oh = parseError loc "Malformed entity string"
 992
 993 -- construct a foreign export declaration
 994 --
 995 mkExport :: CallConv
 996          -> (Located FastString, Located RdrName, LHsType RdrName)
 997          -> P (HsDecl RdrName)
 998 mkExport (CCall  cconv) (L loc entity, v, ty) = return $
 999   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1000   where
1001     entity' | nullFS entity = mkExtName (unLoc v)
1002             | otherwise     = entity
1003 mkExport DNCall (L loc entity, v, ty) =
1004   parseError (getLoc v){-TODO: not quite right-}
1005         "Foreign export is not yet supported for .NET"
1006
1007 -- Supplying the ext_name in a foreign decl is optional; if it
1008 -- isn't there, the Haskell name is assumed. Note that no transformation
1009 -- of the Haskell name is then performed, so if you foreign export (++),
1010 -- it's external name will be "++". Too bad; it's important because we don't
1011 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1012 --
1013 mkExtName :: RdrName -> CLabelString
1014 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1015 \end{code}
1016
1017
1018 -----------------------------------------------------------------------------
1019 -- Misc utils
1020
1021 \begin{code}
1022 showRdrName :: RdrName -> String
1023 showRdrName r = showSDoc (ppr r)
1024
1025 parseError :: SrcSpan -> String -> P a
1026 parseError span s = failSpanMsgP span s
1027 \end{code}