compiler/parser/RdrHsSyn.lhs

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