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