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