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, glaExtsEnabled, bangPatEnabled )
  62 import TysWiredIn       ( unitTyCon )
  63 import ForeignCall      ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
  64                           DNCallSpec(..), DNKind(..), CLabelString )
  65 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
  66                           occNameString )
  67 import SrcLoc
  68 import OrdList          ( OrdList, fromOL )
  69 import Bag              ( Bag, emptyBag, snocBag, consBag, foldrBag )
  70 import Outputable
  71 import FastString
  72
  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, HsConDetails RdrName (LBangType 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, HsConDetails RdrName (LBangType RdrName))
 363 mkRecCon (L loc con) fields
 364   = do data_con <- tyConToDataCon loc con
 365        return (data_con, RecCon [ (HsRecField 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 equation of a type function and return
 417 -- all patterns.  If yes, we return 'Nothing' as the third component to
 418 -- indicate a vanilla 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 -- The unaltered parameter list is returned in the fourth component of the
 446 -- result.  Eg, for
 447 --      T Int [a]
 448 -- we return
 449 --      ('()', 'T', ['a'], ['Int', '[a]'])
 450 checkTyClHdr (L l cxt) ty
 451   = do (tc, tvs, parms) <- gol ty []
 452        mapM_ chk_pred cxt
 453        return (L l cxt, tc, tvs, parms)
 454   where
 455     gol (L l ty) acc = go l ty acc
 456
 457     go l (HsTyVar tc) acc
 458         | isRdrTc tc            = do tvs <- extractTyVars acc
 459                                      return (L l tc, tvs, acc)
 460     go l (HsOpTy t1 ltc@(L _ tc) t2) acc
 461         | isRdrTc tc            = do tvs <- extractTyVars (t1:t2:acc)
 462                                      return (ltc, tvs, acc)
 463     go l (HsParTy ty)    acc    = gol ty acc
 464     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
 465     go l other           acc    =
 466       parseError l "Malformed head of type or class declaration"
 467
 468         -- The predicates in a type or class decl must be class predicates or
 469         -- equational constraints.  They need not all have variable-only
 470         -- arguments, even in Haskell 98.
 471         -- E.g. class (Monad m, Monad (t m)) => MonadT t m
 472     chk_pred (L l (HsClassP _ _)) = return ()
 473     chk_pred (L l (HsEqualP _ _)) = return ()
 474     chk_pred (L l _)
 475        = parseError l "Malformed context in type or class declaration"
 476
 477 -- Extract the type variables of a list of type parameters.
 478 --
 479 -- * Type arguments can be complex type terms (needed for associated type
 480 --   declarations).
 481 --
 482 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 483 extractTyVars tvs = collects [] tvs
 484   where
 485         -- Collect all variables (1st arg serves as an accumulator)
 486     collect tvs (L l (HsForAllTy _ _ _ _)) =
 487       parseError l "Forall type not allowed as type parameter"
 488     collect tvs (L l (HsTyVar tv))
 489       | isRdrTyVar tv                      = return $ L l (UserTyVar tv) : tvs
 490       | otherwise                          = return tvs
 491     collect tvs (L l (HsBangTy _ _      )) =
 492       parseError l "Bang-style type annotations not allowed as type parameter"
 493     collect tvs (L l (HsAppTy t1 t2     )) = do
 494                                                tvs' <- collect tvs t2
 495                                                collect tvs' t1
 496     collect tvs (L l (HsFunTy t1 t2     )) = do
 497                                                tvs' <- collect tvs t2
 498                                                collect tvs' t1
 499     collect tvs (L l (HsListTy t        )) = collect tvs t
 500     collect tvs (L l (HsPArrTy t        )) = collect tvs t
 501     collect tvs (L l (HsTupleTy _ ts    )) = collects tvs ts
 502     collect tvs (L l (HsOpTy t1 _ t2    )) = do
 503                                                tvs' <- collect tvs t2
 504                                                collect tvs' t1
 505     collect tvs (L l (HsParTy t         )) = collect tvs t
 506     collect tvs (L l (HsNumTy t         )) = return tvs
 507     collect tvs (L l (HsPredTy t        )) =
 508       parseError l "Predicate not allowed as type parameter"
 509     collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
 510         | isRdrTyVar tv                    =
 511           return $ L l (KindedTyVar tv k) : tvs
 512         | otherwise                        =
 513           parseError l "Kind signature only allowed for type variables"
 514     collect tvs (L l (HsSpliceTy t      )) =
 515       parseError l "Splice not allowed as type parameter"
 516
 517         -- Collect all variables of a list of types
 518     collects tvs []     = return tvs
 519     collects tvs (t:ts) = do
 520                             tvs' <- collects tvs ts
 521                             collect tvs' t
 522
 523 -- Check that associated type declarations of a class are all kind signatures.
 524 --
 525 checkKindSigs :: [LTyClDecl RdrName] -> P ()
 526 checkKindSigs = mapM_ check
 527   where
 528     check (L l tydecl)
 529       | isFamilyDecl tydecl
 530         || isSynDecl tydecl  = return ()
 531       | otherwise            =
 532         parseError l "Type declaration in a class must be a kind signature or synonym default"
 533
 534 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 535 checkContext (L l t)
 536   = check t
 537  where
 538   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 539     = do ctx <- mapM checkPred ts
 540          return (L l ctx)
 541
 542   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 543     = check (unLoc ty)
 544
 545   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 546     | t == getRdrName unitTyCon = return (L l [])
 547
 548   check t
 549     = do p <- checkPred (L l t)
 550          return (L l [p])
 551
 552
 553 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 554 -- Watch out.. in ...deriving( Show )... we use checkPred on
 555 -- the list of partially applied predicates in the deriving,
 556 -- so there can be zero args.
 557 checkPred (L spn (HsPredTy (HsIParam n ty)))
 558   = return (L spn (HsIParam n ty))
 559 checkPred (L spn ty)
 560   = check spn ty []
 561   where
 562     checkl (L l ty) args = check l ty args
 563
 564     check _loc (HsPredTy pred@(HsEqualP _ _))
 565                                        args | null args
 566                                             = return $ L spn pred
 567     check _loc (HsTyVar t)             args | not (isRdrTyVar t)
 568                                             = return (L spn (HsClassP t args))
 569     check _loc (HsAppTy l r)           args = checkl l (r:args)
 570     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
 571     check _loc (HsParTy t)             args = checkl t args
 572     check loc _                        _    = parseError loc
 573                                                 "malformed class assertion"
 574
 575 ---------------------------------------------------------------------------
 576 -- Checking stand-alone deriving declarations
 577
 578 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
 579 checkDerivDecl d@(L loc _) =
 580     do glaExtOn <- extension glaExtsEnabled
 581        if glaExtOn then return d
 582          else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
 583
 584 ---------------------------------------------------------------------------
 585 -- Checking statements in a do-expression
 586 --      We parse   do { e1 ; e2 ; }
 587 --      as [ExprStmt e1, ExprStmt e2]
 588 -- checkDo (a) checks that the last thing is an ExprStmt
 589 --         (b) returns it separately
 590 -- same comments apply for mdo as well
 591
 592 checkDo  = checkDoMDo "a " "'do'"
 593 checkMDo = checkDoMDo "an " "'mdo'"
 594
 595 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 596 checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 597 checkDoMDo pre nm loc ss   = do
 598   check ss
 599   where
 600         check  [L l (ExprStmt e _ _)] = return ([], e)
 601         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 602                                          " construct must be an expression")
 603         check (s:ss) = do
 604           (ss',e') <-  check ss
 605           return ((s:ss'),e')
 606
 607 -- -------------------------------------------------------------------------
 608 -- Checking Patterns.
 609
 610 -- We parse patterns as expressions and check for valid patterns below,
 611 -- converting the expression into a pattern at the same time.
 612
 613 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 614 checkPattern e = checkLPat e
 615
 616 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 617 checkPatterns es = mapM checkPattern es
 618
 619 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 620 checkLPat e@(L l _) = checkPat l e []
 621
 622 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 623 checkPat loc (L l (HsVar c)) args
 624   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 625 checkPat loc e args     -- OK to let this happen even if bang-patterns
 626                         -- are not enabled, because there is no valid
 627                         -- non-bang-pattern parse of (C ! e)
 628   | Just (e', args') <- splitBang e
 629   = do  { args'' <- checkPatterns args'
 630         ; checkPat loc e' (args'' ++ args) }
 631 checkPat loc (L _ (HsApp f x)) args
 632   = do { x <- checkLPat x; checkPat loc f (x:args) }
 633 checkPat loc (L _ e) []
 634   = do { p <- checkAPat loc e; return (L loc p) }
 635 checkPat loc pat _some_args
 636   = patFail loc
 637
 638 checkAPat loc e = case e of
 639    EWildPat            -> return (WildPat placeHolderType)
 640    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 641                                          ++ showRdrName x)
 642            | otherwise -> return (VarPat x)
 643    HsLit l             -> return (LitPat l)
 644
 645    -- Overloaded numeric patterns (e.g. f 0 x = x)
 646    -- Negation is recorded separately, so that the literal is zero or +ve
 647    -- NB. Negative *primitive* literals are already handled by the lexer
 648    HsOverLit pos_lit            -> return (mkNPat pos_lit Nothing)
 649    NegApp (L _ (HsOverLit pos_lit)) _
 650                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
 651
 652    SectionR (L _ (HsVar bang)) e        -- (! x)
 653         | bang == bang_RDR
 654         -> do { bang_on <- extension bangPatEnabled
 655               ; if bang_on then checkLPat e >>= (return . BangPat)
 656                 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
 657
 658    ELazyPat e         -> checkLPat e >>= (return . LazyPat)
 659    EAsPat n e         -> checkLPat e >>= (return . AsPat n)
 660    ExprWithTySig e t  -> checkLPat e >>= \e ->
 661                          -- Pattern signatures are parsed as sigtypes,
 662                          -- but they aren't explicit forall points.  Hence
 663                          -- we have to remove the implicit forall here.
 664                          let t' = case t of
 665                                      L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 666                                      other -> other
 667                          in
 668                          return (SigPatIn e t')
 669
 670    -- n+k patterns
 671    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 672         (L _ (HsOverLit lit@(HsIntegral _ _)))
 673                       | plus == plus_RDR
 674                       -> return (mkNPlusKPat (L nloc n) lit)
 675
 676    OpApp l op fix r   -> checkLPat l >>= \l ->
 677                          checkLPat r >>= \r ->
 678                          case op of
 679                             L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 680                                    -> return (ConPatIn (L cl c) (InfixCon l r))
 681                             _ -> patFail loc
 682
 683    HsPar e                 -> checkLPat e >>= (return . ParPat)
 684    ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 685                          return (ListPat ps placeHolderType)
 686    ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 687                          return (PArrPat ps placeHolderType)
 688
 689    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
 690                          return (TuplePat ps b placeHolderType)
 691
 692    RecordCon c _ (HsRecordBinds fs)   -> mapM checkPatField fs >>= \fs ->
 693                          return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
 694 -- Generics
 695    HsType ty          -> return (TypePat ty)
 696    _                  -> patFail loc
 697
 698 plus_RDR, bang_RDR :: RdrName
 699 plus_RDR = mkUnqual varName FSLIT("+")  -- Hack
 700 bang_RDR = mkUnqual varName FSLIT("!")  -- Hack
 701
 702 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
 703 checkPatField (n,e) = do
 704   p <- checkLPat e
 705   return (n,p)
 706
 707 patFail loc = parseError loc "Parse error in pattern"
 708
 709
 710 ---------------------------------------------------------------------------
 711 -- Check Equation Syntax
 712
 713 checkValDef :: LHsExpr RdrName
 714             -> Maybe (LHsType RdrName)
 715             -> Located (GRHSs RdrName)
 716             -> P (HsBind RdrName)
 717
 718 checkValDef lhs (Just sig) grhss
 719         -- x :: ty = rhs  parses as a *pattern* binding
 720   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 721
 722 checkValDef lhs opt_sig grhss
 723   = do  { mb_fun <- isFunLhs lhs
 724         ; case mb_fun of
 725             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
 726                                                 fun is_infix pats opt_sig grhss
 727             Nothing -> checkPatBind lhs grhss }
 728
 729 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 730   | isQual (unLoc fun)
 731   = parseError (getLoc fun) ("Qualified name in function definition: "  ++
 732                              showRdrName (unLoc fun))
 733   | otherwise
 734   = do  ps <- checkPatterns pats
 735         let match_span = combineSrcSpans lhs_loc rhs_span
 736         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 737         -- The span of the match covers the entire equation.
 738         -- That isn't quite right, but it'll do for now.
 739
 740 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 741 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 742 makeFunBind fn is_infix ms
 743   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
 744               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 745
 746 checkPatBind lhs (L _ grhss)
 747   = do  { lhs <- checkPattern lhs
 748         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 749
 750 checkValSig
 751         :: LHsExpr RdrName
 752         -> LHsType RdrName
 753         -> P (Sig RdrName)
 754 checkValSig (L l (HsVar v)) ty
 755   | isUnqual v && not (isDataOcc (rdrNameOcc v))
 756   = return (TypeSig (L l v) ty)
 757 checkValSig (L l other)     ty
 758   = parseError l "Invalid type signature"
 759
 760 mkGadtDecl :: Located RdrName
 761            -> LHsType RdrName -- assuming HsType
 762            -> ConDecl RdrName
 763 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
 764 mkGadtDecl name ty                                = mk_gadt_con name [] (noLoc []) ty
 765
 766 mk_gadt_con name qvars cxt ty
 767   = ConDecl { con_name     = name
 768             , con_explicit = Implicit
 769             , con_qvars    = qvars
 770             , con_cxt      = cxt
 771             , con_details  = PrefixCon []
 772             , con_res      = ResTyGADT ty
 773             , con_doc      = Nothing }
 774   -- NB: we put the whole constr type into the ResTyGADT for now;
 775   -- the renamer will unravel it once it has sorted out
 776   -- operator fixities
 777
 778 -- A variable binding is parsed as a FunBind.
 779
 780
 781         -- The parser left-associates, so there should
 782         -- not be any OpApps inside the e's
 783 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 784 -- Splits (f ! g a b) into (f, [(! g), a, b])
 785 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
 786   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 787   where
 788     (arg1,argns) = split_bang r_arg []
 789     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 790     split_bang e                 es = (e,es)
 791 splitBang other = Nothing
 792
 793 isFunLhs :: LHsExpr RdrName
 794          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 795 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 796 --
 797 -- The whole LHS is parsed as a single expression.
 798 -- Any infix operators on the LHS will parse left-associatively
 799 -- E.g.         f !x y !z
 800 --      will parse (rather strangely) as
 801 --              (f ! x y) ! z
 802 --      It's up to isFunLhs to sort out the mess
 803 --
 804 -- a .!. !b
 805
 806 isFunLhs e = go e []
 807  where
 808    go (L loc (HsVar f)) es
 809         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
 810    go (L _ (HsApp f e)) es       = go f (e:es)
 811    go (L _ (HsPar e))   es@(_:_) = go e es
 812
 813         -- For infix function defns, there should be only one infix *function*
 814         -- (though there may be infix *datacons* involved too).  So we don't
 815         -- need fixity info to figure out which function is being defined.
 816         --      a `K1` b `op` c `K2` d
 817         -- must parse as
 818         --      (a `K1` b) `op` (c `K2` d)
 819         -- The renamer checks later that the precedences would yield such a parse.
 820         --
 821         -- There is a complication to deal with bang patterns.
 822         --
 823         -- ToDo: what about this?
 824         --              x + 1 `op` y = ...
 825
 826    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 827         | Just (e',es') <- splitBang e
 828         = do { bang_on <- extension bangPatEnabled
 829              ; if bang_on then go e' (es' ++ es)
 830                else return (Just (L loc' op, True, (l:r:es))) }
 831                 -- No bangs; behave just like the next case
 832         | not (isRdrDataCon op)         -- We have found the function!
 833         = return (Just (L loc' op, True, (l:r:es)))
 834         | otherwise                     -- Infix data con; keep going
 835         = do { mb_l <- go l es
 836              ; case mb_l of
 837                  Just (op', True, j : k : es')
 838                     -> return (Just (op', True, j : op_app : es'))
 839                     where
 840                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
 841                  _ -> return Nothing }
 842    go _ _ = return Nothing
 843
 844 ---------------------------------------------------------------------------
 845 -- Miscellaneous utilities
 846
 847 checkPrecP :: Located Int -> P Int
 848 checkPrecP (L l i)
 849  | 0 <= i && i <= maxPrecedence = return i
 850  | otherwise                    = parseError l "Precedence out of range"
 851
 852 mkRecConstrOrUpdate
 853         :: LHsExpr RdrName
 854         -> SrcSpan
 855         -> HsRecordBinds RdrName
 856         -> P (HsExpr RdrName)
 857
 858 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
 859   = return (RecordCon (L l c) noPostTcExpr fs)
 860 mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
 861   = return (RecordUpd exp fs [] [] [])
 862 mkRecConstrOrUpdate _ loc (HsRecordBinds [])
 863   = parseError loc "Empty record update"
 864
 865 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
 866 -- The Maybe is becuase the user can omit the activation spec (and usually does)
 867 mkInlineSpec Nothing    True  = alwaysInlineSpec        -- INLINE
 868 mkInlineSpec Nothing    False = neverInlineSpec         -- NOINLINE
 869 mkInlineSpec (Just act) inl   = Inline act inl
 870
 871
 872 -----------------------------------------------------------------------------
 873 -- utilities for foreign declarations
 874
 875 -- supported calling conventions
 876 --
 877 data CallConv = CCall  CCallConv        -- ccall or stdcall
 878               | DNCall                  -- .NET
 879
 880 -- construct a foreign import declaration
 881 --
 882 mkImport :: CallConv
 883          -> Safety
 884          -> (Located FastString, Located RdrName, LHsType RdrName)
 885          -> P (HsDecl RdrName)
 886 mkImport (CCall  cconv) safety (entity, v, ty) = do
 887   importSpec <- parseCImport entity cconv safety v
 888   return (ForD (ForeignImport v ty importSpec))
 889 mkImport (DNCall      ) _      (entity, v, ty) = do
 890   spec <- parseDImport entity
 891   return $ ForD (ForeignImport v ty (DNImport spec))
 892
 893 -- parse the entity string of a foreign import declaration for the `ccall' or
 894 -- `stdcall' calling convention'
 895 --
 896 parseCImport :: Located FastString
 897              -> CCallConv
 898              -> Safety
 899              -> Located RdrName
 900              -> P ForeignImport
 901 parseCImport (L loc entity) cconv safety v
 902   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 903   | entity == FSLIT ("dynamic") =
 904     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 905   | entity == FSLIT ("wrapper") =
 906     return $ CImport cconv safety nilFS nilFS CWrapper
 907   | otherwise                  = parse0 (unpackFS entity)
 908     where
 909       -- using the static keyword?
 910       parse0 (' ':                    rest) = parse0 rest
 911       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 912       parse0                          rest  = parse1 rest
 913       -- check for header file name
 914       parse1     ""               = parse4 ""    nilFS        False nilFS
 915       parse1     (' ':rest)       = parse1 rest
 916       parse1 str@('&':_   )       = parse2 str   nilFS
 917       parse1 str@('[':_   )       = parse3 str   nilFS        False
 918       parse1 str
 919         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 920         | otherwise               = parse4 str   nilFS        False nilFS
 921         where
 922           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 923       -- check for address operator (indicating a label import)
 924       parse2     ""         header = parse4 ""   header False nilFS
 925       parse2     (' ':rest) header = parse2 rest header
 926       parse2     ('&':rest) header = parse3 rest header True
 927       parse2 str@('[':_   ) header = parse3 str  header False
 928       parse2 str            header = parse4 str  header False nilFS
 929       -- check for library object name
 930       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 931       parse3 ('[':rest) header isLbl =
 932         case break (== ']') rest of
 933           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 934           _                         -> parseError loc "Missing ']' in entity"
 935       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 936       -- check for name of C function
 937       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
 938       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
 939       parse4 str        header isLbl lib
 940         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 941         | otherwise                      = parseError loc "Malformed entity string"
 942         where
 943           (first, rest) = break (== ' ') str
 944       --
 945       build cid header False lib = return $
 946         CImport cconv safety header lib (CFunction (StaticTarget cid))
 947       build cid header True  lib = return $
 948         CImport cconv safety header lib (CLabel                  cid )
 949
 950 --
 951 -- Unravel a dotnet spec string.
 952 --
 953 parseDImport :: Located FastString -> P DNCallSpec
 954 parseDImport (L loc entity) = parse0 comps
 955  where
 956   comps = words (unpackFS entity)
 957
 958   parse0 [] = d'oh
 959   parse0 (x : xs)
 960     | x == "static" = parse1 True xs
 961     | otherwise     = parse1 False (x:xs)
 962
 963   parse1 _ [] = d'oh
 964   parse1 isStatic (x:xs)
 965     | x == "method" = parse2 isStatic DNMethod xs
 966     | x == "field"  = parse2 isStatic DNField xs
 967     | x == "ctor"   = parse2 isStatic DNConstructor xs
 968   parse1 isStatic xs = parse2 isStatic DNMethod xs
 969
 970   parse2 _ _ [] = d'oh
 971   parse2 isStatic kind (('[':x):xs) =
 972      case x of
 973         [] -> d'oh
 974         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
 975   parse2 isStatic kind xs = parse3 isStatic kind "" xs
 976
 977   parse3 isStatic kind assem [x] =
 978     return (DNCallSpec isStatic kind assem x
 979                           -- these will be filled in once known.
 980                         (error "FFI-dotnet-args")
 981                         (error "FFI-dotnet-result"))
 982   parse3 _ _ _ _ = d'oh
 983
 984   d'oh = parseError loc "Malformed entity string"
 985
 986 -- construct a foreign export declaration
 987 --
 988 mkExport :: CallConv
 989          -> (Located FastString, Located RdrName, LHsType RdrName)
 990          -> P (HsDecl RdrName)
 991 mkExport (CCall  cconv) (L loc entity, v, ty) = return $
 992   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
 993   where
 994     entity' | nullFS entity = mkExtName (unLoc v)
 995             | otherwise     = entity
 996 mkExport DNCall (L loc entity, v, ty) =
 997   parseError (getLoc v){-TODO: not quite right-}
 998         "Foreign export is not yet supported for .NET"
 999
1000 -- Supplying the ext_name in a foreign decl is optional; if it
1001 -- isn't there, the Haskell name is assumed. Note that no transformation
1002 -- of the Haskell name is then performed, so if you foreign export (++),
1003 -- it's external name will be "++". Too bad; it's important because we don't
1004 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1005 --
1006 mkExtName :: RdrName -> CLabelString
1007 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1008 \end{code}
1009
1010
1011 -----------------------------------------------------------------------------
1012 -- Misc utils
1013
1014 \begin{code}
1015 showRdrName :: RdrName -> String
1016 showRdrName r = showSDoc (ppr r)
1017
1018 parseError :: SrcSpan -> String -> P a
1019 parseError span s = failSpanMsgP span s
1020 \end{code}