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