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    -- view pattern is well-formed if the pattern is
 669    EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
 670    ExprWithTySig e t  -> checkLPat e >>= \e ->
 671                          -- Pattern signatures are parsed as sigtypes,
 672                          -- but they aren't explicit forall points.  Hence
 673                          -- we have to remove the implicit forall here.
 674                          let t' = case t of
 675                                      L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 676                                      other -> other
 677                          in
 678                          return (SigPatIn e t')
 679
 680    -- n+k patterns
 681    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 682         (L _ (HsOverLit lit@(HsIntegral _ _ _)))
 683                       | plus == plus_RDR
 684                       -> return (mkNPlusKPat (L nloc n) lit)
 685
 686    OpApp l op fix r   -> checkLPat l >>= \l ->
 687                          checkLPat r >>= \r ->
 688                          case op of
 689                             L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 690                                    -> return (ConPatIn (L cl c) (InfixCon l r))
 691                             _ -> patFail loc
 692
 693    HsPar e                 -> checkLPat e >>= (return . ParPat)
 694    ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 695                          return (ListPat ps placeHolderType)
 696    ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
 697                          return (PArrPat ps placeHolderType)
 698
 699    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
 700                          return (TuplePat ps b placeHolderType)
 701
 702    RecordCon c _ (HsRecFields fs dd)
 703                       -> mapM checkPatField fs >>= \fs ->
 704                          return (ConPatIn c (RecCon (HsRecFields fs dd)))
 705 -- Generics
 706    HsType ty          -> return (TypePat ty)
 707    _                  -> patFail loc
 708
 709 plus_RDR, bang_RDR :: RdrName
 710 plus_RDR = mkUnqual varName FSLIT("+")  -- Hack
 711 bang_RDR = mkUnqual varName FSLIT("!")  -- Hack
 712
 713 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
 714 checkPatField fld = do  { p <- checkLPat (hsRecFieldArg fld)
 715                         ; return (fld { hsRecFieldArg = p }) }
 716
 717 patFail loc = parseError loc "Parse error in pattern"
 718
 719
 720 ---------------------------------------------------------------------------
 721 -- Check Equation Syntax
 722
 723 checkValDef :: LHsExpr RdrName
 724             -> Maybe (LHsType RdrName)
 725             -> Located (GRHSs RdrName)
 726             -> P (HsBind RdrName)
 727
 728 checkValDef lhs (Just sig) grhss
 729         -- x :: ty = rhs  parses as a *pattern* binding
 730   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 731
 732 checkValDef lhs opt_sig grhss
 733   = do  { mb_fun <- isFunLhs lhs
 734         ; case mb_fun of
 735             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
 736                                                 fun is_infix pats opt_sig grhss
 737             Nothing -> checkPatBind lhs grhss }
 738
 739 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 740   | isQual (unLoc fun)
 741   = parseError (getLoc fun) ("Qualified name in function definition: "  ++
 742                              showRdrName (unLoc fun))
 743   | otherwise
 744   = do  ps <- checkPatterns pats
 745         let match_span = combineSrcSpans lhs_loc rhs_span
 746         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 747         -- The span of the match covers the entire equation.
 748         -- That isn't quite right, but it'll do for now.
 749
 750 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 751 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 752 makeFunBind fn is_infix ms
 753   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
 754               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 755
 756 checkPatBind lhs (L _ grhss)
 757   = do  { lhs <- checkPattern lhs
 758         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 759
 760 checkValSig
 761         :: LHsExpr RdrName
 762         -> LHsType RdrName
 763         -> P (Sig RdrName)
 764 checkValSig (L l (HsVar v)) ty
 765   | isUnqual v && not (isDataOcc (rdrNameOcc v))
 766   = return (TypeSig (L l v) ty)
 767 checkValSig (L l other)     ty
 768   = parseError l "Invalid type signature"
 769
 770 mkGadtDecl :: Located RdrName
 771            -> LHsType RdrName -- assuming HsType
 772            -> ConDecl RdrName
 773 mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
 774 mkGadtDecl name ty                                = mk_gadt_con name [] (noLoc []) ty
 775
 776 mk_gadt_con name qvars cxt ty
 777   = ConDecl { con_name     = name
 778             , con_explicit = Implicit
 779             , con_qvars    = qvars
 780             , con_cxt      = cxt
 781             , con_details  = PrefixCon []
 782             , con_res      = ResTyGADT ty
 783             , con_doc      = Nothing }
 784   -- NB: we put the whole constr type into the ResTyGADT for now;
 785   -- the renamer will unravel it once it has sorted out
 786   -- operator fixities
 787
 788 -- A variable binding is parsed as a FunBind.
 789
 790
 791         -- The parser left-associates, so there should
 792         -- not be any OpApps inside the e's
 793 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 794 -- Splits (f ! g a b) into (f, [(! g), a, b])
 795 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
 796   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 797   where
 798     (arg1,argns) = split_bang r_arg []
 799     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 800     split_bang e                 es = (e,es)
 801 splitBang other = Nothing
 802
 803 isFunLhs :: LHsExpr RdrName
 804          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 805 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 806 --
 807 -- The whole LHS is parsed as a single expression.
 808 -- Any infix operators on the LHS will parse left-associatively
 809 -- E.g.         f !x y !z
 810 --      will parse (rather strangely) as
 811 --              (f ! x y) ! z
 812 --      It's up to isFunLhs to sort out the mess
 813 --
 814 -- a .!. !b
 815
 816 isFunLhs e = go e []
 817  where
 818    go (L loc (HsVar f)) es
 819         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
 820    go (L _ (HsApp f e)) es       = go f (e:es)
 821    go (L _ (HsPar e))   es@(_:_) = go e es
 822
 823         -- For infix function defns, there should be only one infix *function*
 824         -- (though there may be infix *datacons* involved too).  So we don't
 825         -- need fixity info to figure out which function is being defined.
 826         --      a `K1` b `op` c `K2` d
 827         -- must parse as
 828         --      (a `K1` b) `op` (c `K2` d)
 829         -- The renamer checks later that the precedences would yield such a parse.
 830         --
 831         -- There is a complication to deal with bang patterns.
 832         --
 833         -- ToDo: what about this?
 834         --              x + 1 `op` y = ...
 835
 836    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 837         | Just (e',es') <- splitBang e
 838         = do { bang_on <- extension bangPatEnabled
 839              ; if bang_on then go e' (es' ++ es)
 840                else return (Just (L loc' op, True, (l:r:es))) }
 841                 -- No bangs; behave just like the next case
 842         | not (isRdrDataCon op)         -- We have found the function!
 843         = return (Just (L loc' op, True, (l:r:es)))
 844         | otherwise                     -- Infix data con; keep going
 845         = do { mb_l <- go l es
 846              ; case mb_l of
 847                  Just (op', True, j : k : es')
 848                     -> return (Just (op', True, j : op_app : es'))
 849                     where
 850                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
 851                  _ -> return Nothing }
 852    go _ _ = return Nothing
 853
 854 ---------------------------------------------------------------------------
 855 -- Miscellaneous utilities
 856
 857 checkPrecP :: Located Int -> P Int
 858 checkPrecP (L l i)
 859  | 0 <= i && i <= maxPrecedence = return i
 860  | otherwise                    = parseError l "Precedence out of range"
 861
 862 mkRecConstrOrUpdate
 863         :: LHsExpr RdrName
 864         -> SrcSpan
 865         -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
 866         -> P (HsExpr RdrName)
 867
 868 mkRecConstrOrUpdate (L l (HsVar c)) loc (fs,dd) | isRdrDataCon c
 869   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
 870 mkRecConstrOrUpdate exp loc (fs,dd)
 871   | null fs   = parseError loc "Empty record update"
 872   | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
 873
 874 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 875 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 876
 877 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
 878 -- The Maybe is becuase the user can omit the activation spec (and usually does)
 879 mkInlineSpec Nothing    True  = alwaysInlineSpec        -- INLINE
 880 mkInlineSpec Nothing    False = neverInlineSpec         -- NOINLINE
 881 mkInlineSpec (Just act) inl   = Inline act inl
 882
 883
 884 -----------------------------------------------------------------------------
 885 -- utilities for foreign declarations
 886
 887 -- supported calling conventions
 888 --
 889 data CallConv = CCall  CCallConv        -- ccall or stdcall
 890               | DNCall                  -- .NET
 891
 892 -- construct a foreign import declaration
 893 --
 894 mkImport :: CallConv
 895          -> Safety
 896          -> (Located FastString, Located RdrName, LHsType RdrName)
 897          -> P (HsDecl RdrName)
 898 mkImport (CCall  cconv) safety (entity, v, ty) = do
 899   importSpec <- parseCImport entity cconv safety v
 900   return (ForD (ForeignImport v ty importSpec))
 901 mkImport (DNCall      ) _      (entity, v, ty) = do
 902   spec <- parseDImport entity
 903   return $ ForD (ForeignImport v ty (DNImport spec))
 904
 905 -- parse the entity string of a foreign import declaration for the `ccall' or
 906 -- `stdcall' calling convention'
 907 --
 908 parseCImport :: Located FastString
 909              -> CCallConv
 910              -> Safety
 911              -> Located RdrName
 912              -> P ForeignImport
 913 parseCImport (L loc entity) cconv safety v
 914   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
 915   | entity == FSLIT ("dynamic") =
 916     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
 917   | entity == FSLIT ("wrapper") =
 918     return $ CImport cconv safety nilFS nilFS CWrapper
 919   | otherwise                  = parse0 (unpackFS entity)
 920     where
 921       -- using the static keyword?
 922       parse0 (' ':                    rest) = parse0 rest
 923       parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
 924       parse0                          rest  = parse1 rest
 925       -- check for header file name
 926       parse1     ""               = parse4 ""    nilFS        False nilFS
 927       parse1     (' ':rest)       = parse1 rest
 928       parse1 str@('&':_   )       = parse2 str   nilFS
 929       parse1 str@('[':_   )       = parse3 str   nilFS        False
 930       parse1 str
 931         | ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
 932         | otherwise               = parse4 str   nilFS        False nilFS
 933         where
 934           (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
 935       -- check for address operator (indicating a label import)
 936       parse2     ""         header = parse4 ""   header False nilFS
 937       parse2     (' ':rest) header = parse2 rest header
 938       parse2     ('&':rest) header = parse3 rest header True
 939       parse2 str@('[':_   ) header = parse3 str  header False
 940       parse2 str            header = parse4 str  header False nilFS
 941       -- check for library object name
 942       parse3 (' ':rest) header isLbl = parse3 rest header isLbl
 943       parse3 ('[':rest) header isLbl =
 944         case break (== ']') rest of
 945           (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
 946           _                         -> parseError loc "Missing ']' in entity"
 947       parse3 str        header isLbl = parse4 str  header isLbl nilFS
 948       -- check for name of C function
 949       parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
 950       parse4 (' ':rest) header isLbl lib = parse4 rest                 header isLbl lib
 951       parse4 str        header isLbl lib
 952         | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
 953         | otherwise                      = parseError loc "Malformed entity string"
 954         where
 955           (first, rest) = break (== ' ') str
 956       --
 957       build cid header False lib = return $
 958         CImport cconv safety header lib (CFunction (StaticTarget cid))
 959       build cid header True  lib = return $
 960         CImport cconv safety header lib (CLabel                  cid )
 961
 962 --
 963 -- Unravel a dotnet spec string.
 964 --
 965 parseDImport :: Located FastString -> P DNCallSpec
 966 parseDImport (L loc entity) = parse0 comps
 967  where
 968   comps = words (unpackFS entity)
 969
 970   parse0 [] = d'oh
 971   parse0 (x : xs)
 972     | x == "static" = parse1 True xs
 973     | otherwise     = parse1 False (x:xs)
 974
 975   parse1 _ [] = d'oh
 976   parse1 isStatic (x:xs)
 977     | x == "method" = parse2 isStatic DNMethod xs
 978     | x == "field"  = parse2 isStatic DNField xs
 979     | x == "ctor"   = parse2 isStatic DNConstructor xs
 980   parse1 isStatic xs = parse2 isStatic DNMethod xs
 981
 982   parse2 _ _ [] = d'oh
 983   parse2 isStatic kind (('[':x):xs) =
 984      case x of
 985         [] -> d'oh
 986         vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
 987   parse2 isStatic kind xs = parse3 isStatic kind "" xs
 988
 989   parse3 isStatic kind assem [x] =
 990     return (DNCallSpec isStatic kind assem x
 991                           -- these will be filled in once known.
 992                         (error "FFI-dotnet-args")
 993                         (error "FFI-dotnet-result"))
 994   parse3 _ _ _ _ = d'oh
 995
 996   d'oh = parseError loc "Malformed entity string"
 997
 998 -- construct a foreign export declaration
 999 --
1000 mkExport :: CallConv
1001          -> (Located FastString, Located RdrName, LHsType RdrName)
1002          -> P (HsDecl RdrName)
1003 mkExport (CCall  cconv) (L loc entity, v, ty) = return $
1004   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1005   where
1006     entity' | nullFS entity = mkExtName (unLoc v)
1007             | otherwise     = entity
1008 mkExport DNCall (L loc entity, v, ty) =
1009   parseError (getLoc v){-TODO: not quite right-}
1010         "Foreign export is not yet supported for .NET"
1011
1012 -- Supplying the ext_name in a foreign decl is optional; if it
1013 -- isn't there, the Haskell name is assumed. Note that no transformation
1014 -- of the Haskell name is then performed, so if you foreign export (++),
1015 -- it's external name will be "++". Too bad; it's important because we don't
1016 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1017 --
1018 mkExtName :: RdrName -> CLabelString
1019 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1020 \end{code}
1021
1022
1023 -----------------------------------------------------------------------------
1024 -- Misc utils
1025
1026 \begin{code}
1027 showRdrName :: RdrName -> String
1028 showRdrName r = showSDoc (ppr r)
1029
1030 parseError :: SrcSpan -> String -> P a
1031 parseError span s = failSpanMsgP span s
1032 \end{code}