compiler/parser/RdrHsSyn.lhs

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