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, 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 \begin{code}
 176 mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
 177 -- RdrName If the type checker sees (negate 3#) it will barf, because negate
 178 -- can't take an unboxed arg.  But that is exactly what it will see when
 179 -- we write "-3#".  So we have to do the negation right now!
 180 mkHsNegApp (L loc e) = f e
 181   where f (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 182         f (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 183         f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 184         f expr                     = NegApp (L loc e) noSyntaxExpr
 185 \end{code}
 186
 187 %************************************************************************
 188 %*                                                                      *
 189 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
 190 %*                                                                      *
 191 %************************************************************************
 192
 193 Function definitions are restructured here. Each is assumed to be recursive
 194 initially, and non recursive definitions are discovered by the dependency
 195 analyser.
 196
 197
 198 \begin{code}
 199 --  | Groups together bindings for a single function
 200 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
 201 cvTopDecls decls = go (fromOL decls)
 202   where
 203     go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
 204     go []                   = []
 205     go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
 206                             where (L l' b', ds') = getMonoBind (L l b) ds
 207     go (d : ds)             = d : go ds
 208
 209 -- Declaration list may only contain value bindings and signatures.
 210 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 211 cvBindGroup binding
 212   = case cvBindsAndSigs binding of
 213       (mbs, sigs, [], _) ->                 -- list of type decls *always* empty
 214         ValBindsIn mbs sigs
 215
 216 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
 217   -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
 218 -- Input decls contain just value bindings and signatures
 219 -- and in case of class or instance declarations also
 220 -- associated type declarations. They might also contain Haddock comments.
 221 cvBindsAndSigs  fb = go (fromOL fb)
 222   where
 223     go []                  = (emptyBag, [], [], [])
 224     go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, docs)
 225                             where (bs, ss, ts, docs) = go ds
 226     go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
 227                             where (b', ds')    = getMonoBind (L l b) ds
 228                                   (bs, ss, ts, docs) = go ds'
 229     go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
 230                             where (bs, ss, ts, docs) = go ds
 231     go (L l (DocD d) : ds)     =  (bs, ss, ts, (L l d) : docs)
 232                             where (bs, ss, ts, docs) = go ds
 233
 234 -----------------------------------------------------------------------------
 235 -- Group function bindings into equation groups
 236
 237 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 238   -> (LHsBind RdrName, [LHsDecl RdrName])
 239 -- Suppose      (b',ds') = getMonoBind b ds
 240 --      ds is a list of parsed bindings
 241 --      b is a MonoBinds that has just been read off the front
 242
 243 -- Then b' is the result of grouping more equations from ds that
 244 -- belong with b into a single MonoBinds, and ds' is the depleted
 245 -- list of parsed bindings.
 246 --
 247 -- All Haddock comments between equations inside the group are
 248 -- discarded.
 249 --
 250 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 251
 252 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
 253                                    fun_matches = MatchGroup mtchs1 _ })) binds
 254   | has_args mtchs1
 255   = go is_infix1 mtchs1 loc1 binds []
 256   where
 257     go is_infix mtchs loc
 258        (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
 259                                 fun_matches = MatchGroup mtchs2 _ })) : binds) _
 260         | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
 261                         (combineSrcSpans loc loc2) binds []
 262     go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
 263         = let doc_decls' = doc_decl : doc_decls
 264           in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
 265     go is_infix mtchs loc binds doc_decls
 266         = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
 267         -- Reverse the final matches, to get it back in the right order
 268         -- Do the same thing with the trailing doc comments
 269
 270 getMonoBind bind binds = (bind, binds)
 271
 272 has_args ((L _ (Match args _ _)) : _) = not (null args)
 273         -- Don't group together FunBinds if they have
 274         -- no arguments.  This is necessary now that variable bindings
 275         -- with no arguments are now treated as FunBinds rather
 276         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 277 \end{code}
 278
 279 \begin{code}
 280 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 281 findSplice ds = addl emptyRdrGroup ds
 282
 283 checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
 284 -- Turn the body of a [d| ... |] into a HsGroup
 285 -- There should be no splices in the "..."
 286 checkDecBrGroup decls
 287   = case addl emptyRdrGroup decls of
 288         (group, Nothing) -> return group
 289         (_, Just (SpliceDecl (L loc _), _)) ->
 290                 parseError loc "Declaration splices are not permitted inside declaration brackets"
 291                 -- Why not?  See Section 7.3 of the TH paper.
 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})
 308     l (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, hs_fixds = fsigs ++ fs}) ds
 312         | otherwise =
 313                 addl (gp { hs_tyclds = L l d : ts }) ds
 314
 315 -- Signatures: fixity sigs go a different place than all others
 316 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
 317   = addl (gp {hs_fixds = L l f : ts}) ds
 318 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
 319   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
 320
 321 -- Value declarations: use add_bind
 322 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
 323   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
 324
 325 -- The rest are routine
 326 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
 327   = addl (gp { hs_instds = L l d : ts }) ds
 328 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
 329   = addl (gp { hs_derivds = L l d : ts }) ds
 330 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
 331   = addl (gp { hs_defds = L l d : ts }) ds
 332 add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
 333   = addl (gp { hs_fords = L l d : ts }) ds
 334 add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
 335   = addl (gp { hs_depds = L l d : ts }) ds
 336 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
 337   = addl (gp { hs_ruleds = L l d : ts }) ds
 338
 339 add gp l (DocD d) ds
 340   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
 341
 342 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 343 add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs               (s:sigs)
 344 \end{code}
 345
 346 %************************************************************************
 347 %*                                                                      *
 348 \subsection[PrefixToHS-utils]{Utilities for conversion}
 349 %*                                                                      *
 350 %************************************************************************
 351
 352
 353 \begin{code}
 354 -----------------------------------------------------------------------------
 355 -- mkPrefixCon
 356
 357 -- When parsing data declarations, we sometimes inadvertently parse
 358 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 359 -- This function splits up the type application, adds any pending
 360 -- arguments, and converts the type constructor back into a data constructor.
 361
 362 mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
 363   -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 364 mkPrefixCon ty tys
 365  = split ty tys
 366  where
 367    split (L _ (HsAppTy t u)) ts = split t (u : ts)
 368    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
 369                                      return (data_con, PrefixCon ts)
 370    split (L l _) _              = parseError l "parse error in data/newtype declaration"
 371
 372 mkRecCon :: Located RdrName ->
 373             [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
 374             P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 375 mkRecCon (L loc con) fields
 376   = do data_con <- tyConToDataCon loc con
 377        return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
 378
 379 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 380 tyConToDataCon loc tc
 381   | isTcOcc (rdrNameOcc tc)
 382   = return (L loc (setRdrNameSpace tc srcDataName))
 383   | otherwise
 384   = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
 385
 386 ----------------------------------------------------------------------------
 387 -- Various Syntactic Checks
 388
 389 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
 390 checkInstType (L l t)
 391   = case t of
 392         HsForAllTy exp tvs ctxt ty -> do
 393                 dict_ty <- checkDictTy ty
 394                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
 395
 396         HsParTy ty -> checkInstType ty
 397
 398         ty ->   do dict_ty <- checkDictTy (L l ty)
 399                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 400
 401 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 402 checkDictTy (L spn ty) = check ty []
 403   where
 404   check (HsTyVar t) args | not (isRdrTyVar t)
 405         = return (L spn (HsPredTy (HsClassP t args)))
 406   check (HsAppTy l r) args = check (unLoc l) (r:args)
 407   check (HsParTy t)   args = check (unLoc t) args
 408   check _ _ = parseError spn "Malformed instance header"
 409
 410 -- Check whether the given list of type parameters are all type variables
 411 -- (possibly with a kind signature).  If the second argument is `False',
 412 -- only type variables are allowed and we raise an error on encountering a
 413 -- non-variable; otherwise, we allow non-variable arguments and return the
 414 -- entire list of parameters.
 415 --
 416 checkTyVars :: [LHsType RdrName] -> P ()
 417 checkTyVars tparms = mapM_ chk tparms
 418   where
 419         -- Check that the name space is correct!
 420     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 421         | isRdrTyVar tv    = return ()
 422     chk (L l (HsTyVar tv))
 423         | isRdrTyVar tv    = return ()
 424     chk (L l other)        =
 425           parseError l "Type found where type variable expected"
 426
 427 -- Check whether the type arguments in a type synonym head are simply
 428 -- variables.  If not, we have a type equation of a type function and return
 429 -- all patterns.  If yes, we return 'Nothing' as the third component to
 430 -- indicate a vanilla type synonym.
 431 --
 432 checkSynHdr :: LHsType RdrName
 433             -> Bool                             -- is type instance?
 434             -> P (Located RdrName,              -- head symbol
 435                   [LHsTyVarBndr RdrName],       -- parameters
 436                   [LHsType RdrName])            -- type patterns
 437 checkSynHdr ty isTyInst =
 438   do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
 439      ; unless isTyInst $ checkTyVars tparms
 440      ; return (tc, tvs, tparms) }
 441
 442
 443 -- Well-formedness check and decomposition of type and class heads.
 444 --
 445 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 446   -> P (LHsContext RdrName,          -- the type context
 447         Located RdrName,             -- the head symbol (type or class name)
 448         [LHsTyVarBndr RdrName],      -- free variables of the non-context part
 449         [LHsType RdrName])           -- parameters of head symbol
 450 -- The header of a type or class decl should look like
 451 --      (C a, D b) => T a b
 452 -- or   T a b
 453 -- or   a + b
 454 -- etc
 455 -- With associated types, we can also have non-variable parameters; ie,
 456 --      T Int [a]
 457 -- The unaltered parameter list is returned in the fourth component of the
 458 -- result.  Eg, for
 459 --      T Int [a]
 460 -- we return
 461 --      ('()', 'T', ['a'], ['Int', '[a]'])
 462 checkTyClHdr (L l cxt) ty
 463   = do (tc, tvs, parms) <- gol ty []
 464        mapM_ chk_pred cxt
 465        return (L l cxt, tc, tvs, parms)
 466   where
 467     gol (L l ty) acc = go l ty acc
 468
 469     go l (HsTyVar tc) acc
 470         | isRdrTc tc            = do tvs <- extractTyVars acc
 471                                      return (L l tc, tvs, acc)
 472     go l (HsOpTy t1 ltc@(L _ tc) t2) acc
 473         | isRdrTc tc            = do tvs <- extractTyVars (t1:t2:acc)
 474                                      return (ltc, tvs, acc)
 475     go l (HsParTy ty)    acc    = gol ty acc
 476     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
 477     go l other           acc    =
 478       parseError l "Malformed head of type or class declaration"
 479
 480         -- The predicates in a type or class decl must be class predicates or
 481         -- equational constraints.  They need not all have variable-only
 482         -- arguments, even in Haskell 98.
 483         -- E.g. class (Monad m, Monad (t m)) => MonadT t m
 484     chk_pred (L l (HsClassP _ _)) = return ()
 485     chk_pred (L l (HsEqualP _ _)) = return ()
 486     chk_pred (L l _)
 487        = parseError l "Malformed context in type or class declaration"
 488
 489 -- Extract the type variables of a list of type parameters.
 490 --
 491 -- * Type arguments can be complex type terms (needed for associated type
 492 --   declarations).
 493 --
 494 extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 495 extractTyVars tvs = collects [] tvs
 496   where
 497         -- Collect all variables (1st arg serves as an accumulator)
 498     collect tvs (L l (HsForAllTy _ _ _ _)) =
 499       parseError l "Forall type not allowed as type parameter"
 500     collect tvs (L l (HsTyVar tv))
 501       | isRdrTyVar tv                      = return $ L l (UserTyVar tv) : tvs
 502       | otherwise                          = return tvs
 503     collect tvs (L l (HsBangTy _ _      )) =
 504       parseError l "Bang-style type annotations not allowed as type parameter"
 505     collect tvs (L l (HsAppTy t1 t2     )) = do
 506                                                tvs' <- collect tvs t2
 507                                                collect tvs' t1
 508     collect tvs (L l (HsFunTy t1 t2     )) = do
 509                                                tvs' <- collect tvs t2
 510                                                collect tvs' t1
 511     collect tvs (L l (HsListTy t        )) = collect tvs t
 512     collect tvs (L l (HsPArrTy t        )) = collect tvs t
 513     collect tvs (L l (HsTupleTy _ ts    )) = collects tvs ts
 514     collect tvs (L l (HsOpTy t1 _ t2    )) = do
 515                                                tvs' <- collect tvs t2
 516                                                collect tvs' t1
 517     collect tvs (L l (HsParTy t         )) = collect tvs t
 518     collect tvs (L l (HsNumTy t         )) = return tvs
 519     collect tvs (L l (HsPredTy t        )) =
 520       parseError l "Predicate not allowed as type parameter"
 521     collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
 522         | isRdrTyVar tv                    =
 523           return $ L l (KindedTyVar tv k) : tvs
 524         | otherwise                        =
 525           parseError l "Kind signature only allowed for type variables"
 526     collect tvs (L l (HsSpliceTy t      )) =
 527       parseError l "Splice not allowed as type parameter"
 528
 529         -- Collect all variables of a list of types
 530     collects tvs []     = return tvs
 531     collects tvs (t:ts) = do
 532                             tvs' <- collects tvs ts
 533                             collect tvs' t
 534
 535 -- Check that associated type declarations of a class are all kind signatures.
 536 --
 537 checkKindSigs :: [LTyClDecl RdrName] -> P ()
 538 checkKindSigs = mapM_ check
 539   where
 540     check (L l tydecl)
 541       | isFamilyDecl tydecl
 542         || isSynDecl tydecl  = return ()
 543       | otherwise            =
 544         parseError l "Type declaration in a class must be a kind signature or synonym default"
 545
 546 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 547 checkContext (L l t)
 548   = check t
 549  where
 550   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 551     = do ctx <- mapM checkPred ts
 552          return (L l ctx)
 553
 554   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 555     = check (unLoc ty)
 556
 557   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 558     | t == getRdrName unitTyCon = return (L l [])
 559
 560   check t
 561     = do p <- checkPred (L l t)
 562          return (L l [p])
 563
 564
 565 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 566 -- Watch out.. in ...deriving( Show )... we use checkPred on
 567 -- the list of partially applied predicates in the deriving,
 568 -- so there can be zero args.
 569 checkPred (L spn (HsPredTy (HsIParam n ty)))
 570   = return (L spn (HsIParam n ty))
 571 checkPred (L spn ty)
 572   = check spn ty []
 573   where
 574     checkl (L l ty) args = check l ty args
 575
 576     check _loc (HsPredTy pred@(HsEqualP _ _))
 577                                        args | null args
 578                                             = return $ L spn pred
 579     check _loc (HsTyVar t)             args | not (isRdrTyVar t)
 580                                             = return (L spn (HsClassP t args))
 581     check _loc (HsAppTy l r)           args = checkl l (r:args)
 582     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
 583     check _loc (HsParTy t)             args = checkl t args
 584     check loc _                        _    = parseError loc
 585                                                 "malformed class assertion"
 586
 587 ---------------------------------------------------------------------------
 588 -- Checking stand-alone deriving declarations
 589
 590 checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
 591 checkDerivDecl d@(L loc _) =
 592     do glaExtOn <- extension glaExtsEnabled
 593        if glaExtOn then return d
 594          else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
 595
 596 ---------------------------------------------------------------------------
 597 -- Checking statements in a do-expression
 598 --      We parse   do { e1 ; e2 ; }
 599 --      as [ExprStmt e1, ExprStmt e2]
 600 -- checkDo (a) checks that the last thing is an ExprStmt
 601 --         (b) returns it separately
 602 -- same comments apply for mdo as well
 603
 604 checkDo  = checkDoMDo "a " "'do'"
 605 checkMDo = checkDoMDo "an " "'mdo'"
 606
 607 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 608 checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 609 checkDoMDo pre nm loc ss   = do
 610   check ss
 611   where
 612         check  [L l (ExprStmt e _ _)] = return ([], e)
 613         check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
 614                                          " construct must be an expression")
 615         check (s:ss) = do
 616           (ss',e') <-  check ss
 617           return ((s:ss'),e')
 618
 619 -- -------------------------------------------------------------------------
 620 -- Checking Patterns.
 621
 622 -- We parse patterns as expressions and check for valid patterns below,
 623 -- converting the expression into a pattern at the same time.
 624
 625 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 626 checkPattern e = checkLPat e
 627
 628 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 629 checkPatterns es = mapM checkPattern es
 630
 631 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 632 checkLPat e@(L l _) = checkPat l e []
 633
 634 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 635 checkPat loc (L l (HsVar c)) args
 636   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 637 checkPat loc e args     -- OK to let this happen even if bang-patterns
 638                         -- are not enabled, because there is no valid
 639                         -- non-bang-pattern parse of (C ! e)
 640   | Just (e', args') <- splitBang e
 641   = do  { args'' <- checkPatterns args'
 642         ; checkPat loc e' (args'' ++ args) }
 643 checkPat loc (L _ (HsApp f x)) args
 644   = do { x <- checkLPat x; checkPat loc f (x:args) }
 645 checkPat loc (L _ e) []
 646   = do { p <- checkAPat loc e; return (L loc p) }
 647 checkPat loc pat _some_args
 648   = patFail loc
 649
 650 checkAPat loc e = case e of
 651    EWildPat            -> return (WildPat placeHolderType)
 652    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 653                                          ++ showRdrName x)
 654            | otherwise -> return (VarPat x)
 655    HsLit l             -> return (LitPat l)
 656
 657    -- Overloaded numeric patterns (e.g. f 0 x = x)
 658    -- Negation is recorded separately, so that the literal is zero or +ve
 659    -- NB. Negative *primitive* literals are already handled by
 660    --     RdrHsSyn.mkHsNegApp
 661    HsOverLit pos_lit            -> return (mkNPat pos_lit Nothing)
 662    NegApp (L _ (HsOverLit pos_lit)) _
 663                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
 664
 665    SectionR (L _ (HsVar bang)) e        -- (! x)
 666         | bang == bang_RDR
 667         -> do { bang_on <- extension bangPatEnabled
 668               ; if bang_on then checkLPat e >>= (return . BangPat)
 669                 else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
 670
 671    ELazyPat e         -> checkLPat e >>= (return . LazyPat)
 672    EAsPat n e         -> checkLPat e >>= (return . AsPat n)
 673    ExprWithTySig e t  -> checkLPat e >>= \e ->
 674                          -- Pattern signatures are parsed as sigtypes,
 675                          -- but they aren't explicit forall points.  Hence
 676                          -- we have to remove the implicit forall here.
 677                          let t' = case t of
 678                                      L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 679                                      other -> other
 680                          in
 681                          return (SigPatIn e t')
 682
 683    -- n+k patterns
 684    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 685         (L _ (HsOverLit lit@(HsIntegral _ _)))
 686                       | plus == plus_RDR
 687                       -> return (mkNPlusKPat (L nloc n) lit)
 688
 689    OpApp l op fix r   -> checkLPat l >>= \l ->
 690                          checkLPat r >>= \r ->
 691                          case op of
 692                             L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 693                                    -> return (ConPatIn (L cl c) (InfixCon l r))
 694                             _ -> patFail loc
 695
 696    HsPar e                 -> checkLPat e >>= (return . ParPat)
 697    ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 698                          return (ListPat ps placeHolderType)
 699    ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 700                          return (PArrPat ps placeHolderType)
 701
 702    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
 703                          return (TuplePat ps b placeHolderType)
 704
 705    RecordCon c _ (HsRecordBinds fs)   -> mapM checkPatField fs >>= \fs ->
 706                          return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
 707 -- Generics
 708    HsType ty          -> return (TypePat ty)
 709    _                  -> patFail loc
 710
 711 plus_RDR, bang_RDR :: RdrName
 712 plus_RDR = mkUnqual varName FSLIT("+")  -- Hack
 713 bang_RDR = mkUnqual varName FSLIT("!")  -- Hack
 714
 715 checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
 716 checkPatField (n,e) = do
 717   p <- checkLPat e
 718   return (n,p)
 719
 720 patFail loc = parseError loc "Parse error in pattern"
 721
 722
 723 ---------------------------------------------------------------------------
 724 -- Check Equation Syntax
 725
 726 checkValDef :: LHsExpr RdrName
 727             -> Maybe (LHsType RdrName)
 728             -> Located (GRHSs RdrName)
 729             -> P (HsBind RdrName)
 730
 731 checkValDef lhs (Just sig) grhss
 732         -- x :: ty = rhs  parses as a *pattern* binding
 733   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 734
 735 checkValDef lhs opt_sig grhss
 736   = do  { mb_fun <- isFunLhs lhs
 737         ; case mb_fun of
 738             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
 739                                                 fun is_infix pats opt_sig grhss
 740             Nothing -> checkPatBind lhs grhss }
 741
 742 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 743   | isQual (unLoc fun)
 744   = parseError (getLoc fun) ("Qualified name in function definition: "  ++
 745                              showRdrName (unLoc fun))
 746   | otherwise
 747   = do  ps <- checkPatterns pats
 748         let match_span = combineSrcSpans lhs_loc rhs_span
 749         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 750         -- The span of the match covers the entire equation.
 751         -- That isn't quite right, but it'll do for now.
 752
 753 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 754 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 755 makeFunBind fn is_infix ms
 756   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
 757               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 758
 759 checkPatBind lhs (L _ grhss)
 760   = do  { lhs <- checkPattern lhs
 761         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 762
 763 checkValSig
 764         :: LHsExpr RdrName
 765         -> LHsType RdrName
 766         -> P (Sig RdrName)
 767 checkValSig (L l (HsVar v)) ty
 768   | isUnqual v && not (isDataOcc (rdrNameOcc v))
 769   = return (TypeSig (L l v) ty)
 770 checkValSig (L l other)     ty
 771   = parseError l "Invalid type signature"
 772
 773 mkGadtDecl :: Located RdrName
 774            -> LHsType RdrName -- assuming HsType
 775            -> ConDecl RdrName
 776 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
 777 mkGadtDecl name ty                                = mk_gadt_con name [] (noLoc []) ty
 778
 779 mk_gadt_con name qvars cxt ty
 780   = ConDecl { con_name     = name
 781             , con_explicit = Implicit
 782             , con_qvars    = qvars
 783             , con_cxt      = cxt
 784             , con_details  = PrefixCon []
 785             , con_res      = ResTyGADT ty
 786             , con_doc      = Nothing }
 787   -- NB: we put the whole constr type into the ResTyGADT for now;
 788   -- the renamer will unravel it once it has sorted out
 789   -- operator fixities
 790
 791 -- A variable binding is parsed as a FunBind.
 792
 793
 794         -- The parser left-associates, so there should
 795         -- not be any OpApps inside the e's
 796 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 797 -- Splits (f ! g a b) into (f, [(! g), a, b])
 798 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
 799   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 800   where
 801     (arg1,argns) = split_bang r_arg []
 802     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 803     split_bang e                 es = (e,es)
 804 splitBang other = Nothing
 805
 806 isFunLhs :: LHsExpr RdrName
 807          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 808 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 809 --
 810 -- The whole LHS is parsed as a single expression.
 811 -- Any infix operators on the LHS will parse left-associatively
 812 -- E.g.         f !x y !z
 813 --      will parse (rather strangely) as
 814 --              (f ! x y) ! z
 815 --      It's up to isFunLhs to sort out the mess
 816 --
 817 -- a .!. !b
 818
 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@(HsRecordBinds (_:_))
 874   = return (RecordUpd exp fs [] [] [])
 875 mkRecConstrOrUpdate _ loc (HsRecordBinds [])
 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}