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