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,
  12         mkHsIntegral, mkHsFractional, mkHsIsString,
  13         mkHsDo, mkHsSplice, mkTopSpliceDecl,
  14         mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
  15         splitCon, mkInlinePragma,
  16         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
  17
  18         cvBindGroup,
  19         cvBindsAndSigs,
  20         cvTopDecls,
  21         placeHolderPunRhs,
  22
  23         -- Stuff to do with Foreign declarations
  24         mkImport,
  25         parseCImport,
  26         mkExport,
  27         mkExtName,           -- RdrName -> CLabelString
  28         mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
  29         mkSimpleConDecl,
  30         mkDeprecatedGadtRecordDecl,
  31
  32         -- Bunch of functions in the parser monad for
  33         -- checking and constructing values
  34         checkPrecP,           -- Int -> P Int
  35         checkContext,         -- HsType -> P HsContext
  36         checkPred,            -- HsType -> P HsPred
  37         checkTyVars,          -- [LHsType RdrName] -> P ()
  38         checkKindSigs,        -- [LTyClDecl RdrName] -> P ()
  39         checkInstType,        -- HsType -> P HsType
  40         checkPattern,         -- HsExp -> P HsPat
  41         bang_RDR,
  42         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
  43         checkMonadComp,       -- P (HsStmtContext RdrName)
  44         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  45         checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  46         checkDoAndIfThenElse,
  47         parseError,
  48         parseErrorSDoc,
  49     ) where
  50
  51 import HsSyn            -- Lots of it
  52 import Class            ( FunDep )
  53 import TypeRep          ( Kind )
  54 import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
  55                           isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
  56 import Name             ( Name )
  57 import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
  58                           InlinePragma(..), InlineSpec(..) )
  59 import Lexer
  60 import TysWiredIn       ( unitTyCon )
  61 import ForeignCall
  62 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
  63                           occNameString )
  64 import PrelNames        ( forall_tv_RDR )
  65 import DynFlags
  66 import SrcLoc
  67 import OrdList          ( OrdList, fromOL )
  68 import Bag              ( Bag, emptyBag, consBag, foldrBag )
  69 import Outputable
  70 import FastString
  71 import Maybes
  72
  73 import Control.Applicative ((<$>))
  74 import Control.Monad
  75 import Text.ParserCombinators.ReadP as ReadP
  76 import Data.List        ( nubBy )
  77 import Data.Char
  78
  79 #include "HsVersions.h"
  80 \end{code}
  81
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 \subsection{A few functions over HsSyn at RdrName}
  86 %*                                                                    *
  87 %************************************************************************
  88
  89 extractHsTyRdrNames finds the free variables of a HsType
  90 It's used when making the for-alls explicit.
  91
  92 \begin{code}
  93 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
  94 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
  95
  96 extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
  97 extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
  98
  99 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
 100 -- This one takes the context and tau-part of a
 101 -- sigma type and returns their free type variables
 102 extractHsRhoRdrTyVars ctxt ty
 103  = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
 104
 105 extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
 106 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
 107
 108 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
 109 extract_pred (HsClassP _   tys) acc = extract_ltys tys acc
 110 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
 111 extract_pred (HsIParam _   ty ) acc = extract_lty ty acc
 112
 113 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
 114 extract_ltys tys acc = foldr extract_lty acc tys
 115
 116 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
 117 extract_lty (L loc ty) acc
 118   = case ty of
 119       HsTyVar tv                -> extract_tv loc tv acc
 120       HsBangTy _ ty             -> extract_lty ty acc
 121       HsRecTy flds              -> foldr (extract_lty . cd_fld_type) acc flds
 122       HsAppTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
 123       HsListTy ty               -> extract_lty ty acc
 124       HsPArrTy ty               -> extract_lty ty acc
 125       HsTupleTy _ tys           -> extract_ltys tys acc
 126       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
 127       HsPredTy p                -> extract_pred p acc
 128       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
 129       HsParTy ty                -> extract_lty ty acc
 130       HsNumTy {}                -> acc
 131       HsCoreTy {}               -> acc  -- The type is closed
 132       HsQuasiQuoteTy {}         -> acc  -- Quasi quotes mention no type variables
 133       HsSpliceTy {}             -> acc  -- Type splices mention no type variables
 134       HsKindSig ty _            -> extract_lty ty acc
 135       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
 136       HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
 137                                            extract_lctxt cx (extract_lty ty []))
 138                                 where
 139                                    locals = hsLTyVarNames tvs
 140       HsDocTy ty _              -> extract_lty ty acc
 141
 142 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
 143 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
 144                       | otherwise     = acc
 145
 146 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
 147 -- Get the type variables out of the type patterns in a bunch of
 148 -- possibly-generic bindings in a class declaration
 149 extractGenericPatTyVars binds
 150   = nubBy eqLocated (foldrBag get [] binds)
 151   where
 152     get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
 153     get _                                                 acc = acc
 154
 155     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
 156     get_m _                                        acc = acc
 157 \end{code}
 158
 159
 160 %************************************************************************
 161 %*                                                                      *
 162 \subsection{Construction functions for Rdr stuff}
 163 %*                                                                    *
 164 %************************************************************************
 165
 166 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 167 by deriving them from the name of the class.  We fill in the names for the
 168 tycon and datacon corresponding to the class, by deriving them from the
 169 name of the class itself.  This saves recording the names in the interface
 170 file (which would be equally good).
 171
 172 Similarly for mkConDecl, mkClassOpSig and default-method names.
 173
 174         *** See "THE NAMING STORY" in HsDecls ****
 175
 176 \begin{code}
 177 mkClassDecl :: SrcSpan
 178             -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
 179             -> Located [Located (FunDep RdrName)]
 180             -> Located (OrdList (LHsDecl RdrName))
 181             -> P (LTyClDecl RdrName)
 182
 183 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
 184   = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
 185        ; let cxt = fromMaybe (noLoc []) mcxt
 186        ; (cls, tparams) <- checkTyClHdr tycl_hdr
 187        ; tyvars <- checkTyVars tparams      -- Only type vars allowed
 188        ; checkKindSigs ats
 189        ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
 190                                     tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
 191                                     tcdATs   = ats, tcdDocs  = docs })) }
 192
 193 mkTyData :: SrcSpan
 194          -> NewOrData
 195          -> Bool                -- True <=> data family instance
 196          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
 197          -> Maybe Kind
 198          -> [LConDecl RdrName]
 199          -> Maybe [LHsType RdrName]
 200          -> P (LTyClDecl RdrName)
 201 mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
 202   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
 203
 204        ; checkDatatypeContext mcxt
 205        ; let cxt = fromMaybe (noLoc []) mcxt
 206        ; (tyvars, typats) <- checkTParams is_family tparams
 207        ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
 208                                  tcdTyVars = tyvars, tcdTyPats = typats,
 209                                  tcdCons = data_cons,
 210                                  tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
 211
 212 mkTySynonym :: SrcSpan
 213             -> Bool             -- True <=> type family instances
 214             -> LHsType RdrName  -- LHS
 215             -> LHsType RdrName  -- RHS
 216             -> P (LTyClDecl RdrName)
 217 mkTySynonym loc is_family lhs rhs
 218   = do { (tc, tparams) <- checkTyClHdr lhs
 219        ; (tyvars, typats) <- checkTParams is_family tparams
 220        ; return (L loc (TySynonym tc tyvars typats rhs)) }
 221
 222 mkTyFamily :: SrcSpan
 223            -> FamilyFlavour
 224            -> LHsType RdrName   -- LHS
 225            -> Maybe Kind        -- Optional kind signature
 226            -> P (LTyClDecl RdrName)
 227 mkTyFamily loc flavour lhs ksig
 228   = do { (tc, tparams) <- checkTyClHdr lhs
 229        ; tyvars <- checkTyVars tparams
 230        ; return (L loc (TyFamily flavour tc tyvars ksig)) }
 231
 232 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 233 -- If the user wrote
 234 --      [pads| ... ]   then return a QuasiQuoteD
 235 --      $(e)           then return a SpliceD
 236 -- but if she wrote, say,
 237 --      f x            then behave as if she'd written $(f x)
 238 --                     ie a SpliceD
 239 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq
 240 mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr       Explicit)
 241 mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr Implicit)
 242 \end{code}
 243
 244 %************************************************************************
 245 %*                                                                      *
 246 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
 247 %*                                                                      *
 248 %************************************************************************
 249
 250 Function definitions are restructured here. Each is assumed to be recursive
 251 initially, and non recursive definitions are discovered by the dependency
 252 analyser.
 253
 254
 255 \begin{code}
 256 --  | Groups together bindings for a single function
 257 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
 258 cvTopDecls decls = go (fromOL decls)
 259   where
 260     go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
 261     go []                   = []
 262     go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
 263                             where (L l' b', ds') = getMonoBind (L l b) ds
 264     go (d : ds)             = d : go ds
 265
 266 -- Declaration list may only contain value bindings and signatures.
 267 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 268 cvBindGroup binding
 269   = case cvBindsAndSigs binding of
 270       (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
 271                                  ValBindsIn mbs sigs
 272
 273 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
 274   -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
 275 -- Input decls contain just value bindings and signatures
 276 -- and in case of class or instance declarations also
 277 -- associated type declarations. They might also contain Haddock comments.
 278 cvBindsAndSigs  fb = go (fromOL fb)
 279   where
 280     go []                  = (emptyBag, [], [], [])
 281     go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
 282                            where (bs, ss, ts, docs) = go ds
 283     go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
 284                            where (b', ds')    = getMonoBind (L l b) ds
 285                                  (bs, ss, ts, docs) = go ds'
 286     go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
 287                            where (bs, ss, ts, docs) = go ds
 288     go (L l (DocD d) : ds) =  (bs, ss, ts, (L l d) : docs)
 289                            where (bs, ss, ts, docs) = go ds
 290     go (L _ d : _)        = pprPanic "cvBindsAndSigs" (ppr d)
 291
 292 -----------------------------------------------------------------------------
 293 -- Group function bindings into equation groups
 294
 295 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 296   -> (LHsBind RdrName, [LHsDecl RdrName])
 297 -- Suppose      (b',ds') = getMonoBind b ds
 298 --      ds is a list of parsed bindings
 299 --      b is a MonoBinds that has just been read off the front
 300
 301 -- Then b' is the result of grouping more equations from ds that
 302 -- belong with b into a single MonoBinds, and ds' is the depleted
 303 -- list of parsed bindings.
 304 --
 305 -- All Haddock comments between equations inside the group are
 306 -- discarded.
 307 --
 308 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 309
 310 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
 311                                fun_matches = MatchGroup mtchs1 _ })) binds
 312   | has_args mtchs1
 313   = go is_infix1 mtchs1 loc1 binds []
 314   where
 315     go is_infix mtchs loc
 316        (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
 317                                 fun_matches = MatchGroup mtchs2 _ })) : binds) _
 318         | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
 319                         (combineSrcSpans loc loc2) binds []
 320     go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
 321         = let doc_decls' = doc_decl : doc_decls
 322           in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
 323     go is_infix mtchs loc binds doc_decls
 324         = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
 325         -- Reverse the final matches, to get it back in the right order
 326         -- Do the same thing with the trailing doc comments
 327
 328 getMonoBind bind binds = (bind, binds)
 329
 330 has_args :: [LMatch RdrName] -> Bool
 331 has_args []                           = panic "RdrHsSyn:has_args"
 332 has_args ((L _ (Match args _ _)) : _) = not (null args)
 333         -- Don't group together FunBinds if they have
 334         -- no arguments.  This is necessary now that variable bindings
 335         -- with no arguments are now treated as FunBinds rather
 336         -- than pattern bindings (tests/rename/should_fail/rnfail002).
 337 \end{code}
 338
 339 %************************************************************************
 340 %*                                                                      *
 341 \subsection[PrefixToHS-utils]{Utilities for conversion}
 342 %*                                                                      *
 343 %************************************************************************
 344
 345
 346 \begin{code}
 347 -----------------------------------------------------------------------------
 348 -- splitCon
 349
 350 -- When parsing data declarations, we sometimes inadvertently parse
 351 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 352 -- This function splits up the type application, adds any pending
 353 -- arguments, and converts the type constructor back into a data constructor.
 354
 355 splitCon :: LHsType RdrName
 356       -> P (Located RdrName, HsConDeclDetails RdrName)
 357 -- This gets given a "type" that should look like
 358 --      C Int Bool
 359 -- or   C { x::Int, y::Bool }
 360 -- and returns the pieces
 361 splitCon ty
 362  = split ty []
 363  where
 364    split (L _ (HsAppTy t u)) ts = split t (u : ts)
 365    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
 366                                      return (data_con, mk_rest ts)
 367    split (L l _) _              = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
 368
 369    mk_rest [L _ (HsRecTy flds)] = RecCon flds
 370    mk_rest ts                   = PrefixCon ts
 371
 372 mkDeprecatedGadtRecordDecl :: SrcSpan
 373                            -> Located RdrName
 374                            -> [ConDeclField RdrName]
 375                            -> LHsType RdrName
 376                            ->  P (LConDecl  RdrName)
 377 -- This one uses the deprecated syntax
 378 --    C { x,y ::Int } :: T a b
 379 -- We give it a RecCon details right away
 380 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
 381   = do { data_con <- tyConToDataCon con_loc con
 382        ; return (L loc (ConDecl { con_old_rec  = True
 383                                 , con_name     = data_con
 384                                 , con_explicit = Implicit
 385                                 , con_qvars    = []
 386                                 , con_cxt      = noLoc []
 387                                 , con_details  = RecCon flds
 388                                 , con_res      = ResTyGADT res_ty
 389                                 , con_doc      = Nothing })) }
 390
 391 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
 392                 -> LHsContext RdrName -> HsConDeclDetails RdrName
 393                 -> ConDecl RdrName
 394
 395 mkSimpleConDecl name qvars cxt details
 396   = ConDecl { con_old_rec  = False
 397             , con_name     = name
 398             , con_explicit = Explicit
 399             , con_qvars    = qvars
 400             , con_cxt      = cxt
 401             , con_details  = details
 402             , con_res      = ResTyH98
 403             , con_doc      = Nothing }
 404
 405 mkGadtDecl :: [Located RdrName]
 406            -> LHsType RdrName     -- Always a HsForAllTy
 407            -> [ConDecl RdrName]
 408 -- We allow C,D :: ty
 409 -- and expand it as if it had been
 410 --    C :: ty; D :: ty
 411 -- (Just like type signatures in general.)
 412 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
 413   = [mk_gadt_con name | name <- names]
 414   where
 415     (details, res_ty)           -- See Note [Sorting out the result type]
 416       = case tau of
 417           L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds,  res_ty)
 418           _other                                    -> (PrefixCon [], tau)
 419
 420     mk_gadt_con name
 421        = ConDecl { con_old_rec  = False
 422                  , con_name     = name
 423                  , con_explicit = imp
 424                  , con_qvars    = qvars
 425                  , con_cxt      = cxt
 426                  , con_details  = details
 427                  , con_res      = ResTyGADT res_ty
 428                  , con_doc      = Nothing }
 429 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
 430
 431 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 432 tyConToDataCon loc tc
 433   | isTcOcc (rdrNameOcc tc)
 434   = return (L loc (setRdrNameSpace tc srcDataName))
 435   | otherwise
 436   = parseErrorSDoc loc (msg $$ extra)
 437   where
 438     msg = text "Not a data constructor:" <+> quotes (ppr tc)
 439     extra | tc == forall_tv_RDR
 440           = text "Perhaps you intended to use -XExistentialQuantification"
 441           | otherwise = empty
 442 \end{code}
 443
 444 Note [Sorting out the result type]
 445 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 446 In a GADT declaration which is not a record, we put the whole constr
 447 type into the ResTyGADT for now; the renamer will unravel it once it
 448 has sorted out operator fixities. Consider for example
 449      C :: a :*: b -> a :*: b -> a :+: b
 450 Initially this type will parse as
 451       a :*: (b -> (a :*: (b -> (a :+: b))))
 452
 453 so it's hard to split up the arguments until we've done the precedence
 454 resolution (in the renamer) On the other hand, for a record
 455         { x,y :: Int } -> a :*: b
 456 there is no doubt.  AND we need to sort records out so that
 457 we can bring x,y into scope.  So:
 458    * For PrefixCon we keep all the args in the ResTyGADT
 459    * For RecCon we do not
 460
 461 \begin{code}
 462 ----------------------------------------------------------------------------
 463 -- Various Syntactic Checks
 464
 465 checkInstType :: LHsType RdrName -> P (LHsType RdrName)
 466 checkInstType (L l t)
 467   = case t of
 468         HsForAllTy exp tvs ctxt ty -> do
 469                 dict_ty <- checkDictTy ty
 470                 return (L l (HsForAllTy exp tvs ctxt dict_ty))
 471
 472         HsParTy ty -> checkInstType ty
 473
 474         ty ->   do dict_ty <- checkDictTy (L l ty)
 475                    return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 476
 477 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
 478 checkDictTy (L spn ty) = check ty []
 479   where
 480   check (HsTyVar tc)            args | isRdrTc tc = done tc args
 481   check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
 482   check (HsAppTy l r) args = check (unLoc l) (r:args)
 483   check (HsParTy t)   args = check (unLoc t) args
 484   check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty)
 485
 486   done tc args = return (L spn (HsPredTy (HsClassP tc args)))
 487
 488 checkTParams :: Bool      -- Type/data family
 489              -> [LHsType RdrName]
 490              -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
 491 -- checkTParams checks the type parameters of a data/newtype declaration
 492 -- There are two cases:
 493 --
 494 --  a) Vanilla data/newtype decl. In that case
 495 --        - the type parameters should all be type variables
 496 --        - they may have a kind annotation
 497 --
 498 --  b) Family data/newtype decl.  In that case
 499 --        - The type parameters may be arbitrary types
 500 --        - We find the type-varaible binders by find the
 501 --          free type vars of those types
 502 --        - We make them all kind-sig-free binders (UserTyVar)
 503 --          If there are kind sigs in the type parameters, they
 504 --          will fix the binder's kind when we kind-check the
 505 --          type parameters
 506 checkTParams is_family tparams
 507   | not is_family        -- Vanilla case (a)
 508   = do { tyvars <- checkTyVars tparams
 509        ; return (tyvars, Nothing) }
 510   | otherwise            -- Family case (b)
 511   = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
 512        ; return (tyvars, Just tparams) }
 513
 514 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 515 -- Check whether the given list of type parameters are all type variables
 516 -- (possibly with a kind signature).  If the second argument is `False',
 517 -- only type variables are allowed and we raise an error on encountering a
 518 -- non-variable; otherwise, we allow non-variable arguments and return the
 519 -- entire list of parameters.
 520 checkTyVars tparms = mapM chk tparms
 521   where
 522         -- Check that the name space is correct!
 523     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 524         | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
 525     chk (L l (HsTyVar tv))
 526         | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
 527     chk t@(L l _)            =
 528           parseErrorSDoc l (text "Type found:" <+> ppr t
 529                      $$ text "where type variable expected, in:" <+>
 530                         sep (map (pprParendHsType . unLoc) tparms))
 531
 532 checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
 533 checkDatatypeContext Nothing = return ()
 534 checkDatatypeContext (Just (L loc c))
 535     = do allowed <- extension datatypeContextsEnabled
 536          unless allowed $
 537              parseErrorSDoc loc
 538                  (text "Illegal datatype context (use -XDatatypeContexts):" <+>
 539                   pprHsContext c)
 540
 541 checkTyClHdr :: LHsType RdrName
 542              -> P (Located RdrName,          -- the head symbol (type or class name)
 543                    [LHsType RdrName])        -- parameters of head symbol
 544 -- Well-formedness check and decomposition of type and class heads.
 545 -- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
 546 --              Int :*: Bool   into    (:*:, [Int, Bool])
 547 -- returning the pieces
 548 checkTyClHdr ty
 549   = goL ty []
 550   where
 551     goL (L l ty) acc = go l ty acc
 552
 553     go l (HsTyVar tc) acc
 554         | isRdrTc tc         = return (L l tc, acc)
 555
 556     go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
 557         | isRdrTc tc         = return (ltc, t1:t2:acc)
 558     go _ (HsParTy ty)    acc = goL ty acc
 559     go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
 560     go l _               _   = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
 561
 562 -- Check that associated type declarations of a class are all kind signatures.
 563 --
 564 checkKindSigs :: [LTyClDecl RdrName] -> P ()
 565 checkKindSigs = mapM_ check
 566   where
 567     check (L l tydecl)
 568       | isFamilyDecl tydecl
 569         || isSynDecl tydecl  = return ()
 570       | otherwise            =
 571         parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl)
 572
 573 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 574 checkContext (L l t)
 575   = check t
 576  where
 577   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
 578     = do ctx <- mapM checkPred ts
 579          return (L l ctx)
 580
 581   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
 582     = check (unLoc ty)
 583
 584   check (HsTyVar t)     -- Empty context shows up as a unit type ()
 585     | t == getRdrName unitTyCon = return (L l [])
 586
 587   check t
 588     = do p <- checkPred (L l t)
 589          return (L l [p])
 590
 591
 592 checkPred :: LHsType RdrName -> P (LHsPred RdrName)
 593 -- Watch out.. in ...deriving( Show )... we use checkPred on
 594 -- the list of partially applied predicates in the deriving,
 595 -- so there can be zero args.
 596 checkPred (L spn (HsPredTy (HsIParam n ty)))
 597   = return (L spn (HsIParam n ty))
 598 checkPred (L spn ty)
 599   = check spn ty []
 600   where
 601     checkl (L l ty) args = check l ty args
 602
 603     check _loc (HsPredTy pred@(HsEqualP _ _))
 604                                        args | null args
 605                                             = return $ L spn pred
 606     check _loc (HsTyVar t)             args | not (isRdrTyVar t)
 607                                             = return (L spn (HsClassP t args))
 608     check _loc (HsAppTy l r)           args = checkl l (r:args)
 609     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
 610     check _loc (HsParTy t)             args = checkl t args
 611     check loc _                        _    = parseErrorSDoc loc
 612                                 (text "malformed class assertion:" <+> ppr ty)
 613
 614 -- -------------------------------------------------------------------------
 615 -- Checking Patterns.
 616
 617 -- We parse patterns as expressions and check for valid patterns below,
 618 -- converting the expression into a pattern at the same time.
 619
 620 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 621 checkPattern e = checkLPat e
 622
 623 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 624 checkPatterns es = mapM checkPattern es
 625
 626 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 627 checkLPat e@(L l _) = checkPat l e []
 628
 629 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 630 checkPat loc (L l (HsVar c)) args
 631   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 632 checkPat loc e args     -- OK to let this happen even if bang-patterns
 633                         -- are not enabled, because there is no valid
 634                         -- non-bang-pattern parse of (C ! e)
 635   | Just (e', args') <- splitBang e
 636   = do  { args'' <- checkPatterns args'
 637         ; checkPat loc e' (args'' ++ args) }
 638 checkPat loc (L _ (HsApp f x)) args
 639   = do { x <- checkLPat x; checkPat loc f (x:args) }
 640 checkPat loc (L _ e) []
 641   = do { pState <- getPState
 642        ; p <- checkAPat (dflags pState) loc e
 643        ; return (L loc p) }
 644 checkPat loc e _
 645   = patFail loc (unLoc e)
 646
 647 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
 648 checkAPat dynflags loc e0 = case e0 of
 649    EWildPat -> return (WildPat placeHolderType)
 650    HsVar x  -> 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 parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) }
 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  -> do e <- checkLPat 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                             return (SigPatIn e t')
 678
 679    -- n+k patterns
 680    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 681          (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
 682                       | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
 683                       -> return (mkNPlusKPat (L nloc n) lit)
 684
 685    OpApp l op _fix r  -> do l <- checkLPat l
 686                             r <- checkLPat r
 687                             case op of
 688                                L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 689                                       -> return (ConPatIn (L cl c) (InfixCon l r))
 690                                _ -> patFail loc e0
 691
 692    HsPar e            -> checkLPat e >>= (return . ParPat)
 693    ExplicitList _ es  -> do ps <- mapM checkLPat es
 694                             return (ListPat ps placeHolderType)
 695    ExplicitPArr _ es  -> do ps <- mapM checkLPat es
 696                             return (PArrPat ps placeHolderType)
 697
 698    ExplicitTuple es b
 699      | all tupArgPresent es  -> do ps <- mapM checkLPat [e | Present e <- es]
 700                                    return (TuplePat ps b placeHolderType)
 701      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 702
 703    RecordCon c _ (HsRecFields fs dd)
 704                       -> do fs <- mapM checkPatField fs
 705                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
 706    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
 707 -- Generics
 708    HsType ty          -> return (TypePat ty)
 709    _                  -> patFail loc e0
 710
 711 placeHolderPunRhs :: LHsExpr RdrName
 712 -- The RHS of a punned record field will be filled in by the renamer
 713 -- It's better not to make it an error, in case we want to print it when debugging
 714 placeHolderPunRhs = noLoc (HsVar pun_RDR)
 715
 716 plus_RDR, bang_RDR, pun_RDR :: RdrName
 717 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
 718 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
 719 pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
 720
 721 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
 722 checkPatField fld = do  { p <- checkLPat (hsRecFieldArg fld)
 723                         ; return (fld { hsRecFieldArg = p }) }
 724
 725 patFail :: SrcSpan -> HsExpr RdrName -> P a
 726 patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e)
 727
 728
 729 ---------------------------------------------------------------------------
 730 -- Check Equation Syntax
 731
 732 checkValDef :: LHsExpr RdrName
 733             -> Maybe (LHsType RdrName)
 734             -> Located (GRHSs RdrName)
 735             -> P (HsBind RdrName)
 736
 737 checkValDef lhs (Just sig) grhss
 738         -- x :: ty = rhs  parses as a *pattern* binding
 739   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 740
 741 checkValDef lhs opt_sig grhss
 742   = do  { mb_fun <- isFunLhs lhs
 743         ; case mb_fun of
 744             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
 745                                                 fun is_infix pats opt_sig grhss
 746             Nothing -> checkPatBind lhs grhss }
 747
 748 checkFunBind :: SrcSpan
 749              -> Located RdrName
 750              -> Bool
 751              -> [LHsExpr RdrName]
 752              -> Maybe (LHsType RdrName)
 753              -> Located (GRHSs RdrName)
 754              -> P (HsBind RdrName)
 755 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 756   = do  ps <- checkPatterns pats
 757         let match_span = combineSrcSpans lhs_loc rhs_span
 758         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 759         -- The span of the match covers the entire equation.
 760         -- That isn't quite right, but it'll do for now.
 761
 762 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 763 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 764 makeFunBind fn is_infix ms
 765   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
 766               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 767
 768 checkPatBind :: LHsExpr RdrName
 769              -> Located (GRHSs RdrName)
 770              -> P (HsBind RdrName)
 771 checkPatBind lhs (L _ grhss)
 772   = do  { lhs <- checkPattern lhs
 773         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 774
 775 checkValSig
 776         :: LHsExpr RdrName
 777         -> LHsType RdrName
 778         -> P (Sig RdrName)
 779 checkValSig (L l (HsVar v)) ty
 780   | isUnqual v && not (isDataOcc (rdrNameOcc v))
 781   = return (TypeSig (L l v) ty)
 782 checkValSig lhs@(L l _) ty
 783   = parseErrorSDoc l ((text "Invalid type signature:" <+>
 784                        ppr lhs <+> text "::" <+> ppr ty)
 785                    $$ text hint)
 786   where
 787     hint = if looks_like_foreign lhs
 788            then "Perhaps you meant to use -XForeignFunctionInterface?"
 789            else "Should be of form <variable> :: <type>"
 790     -- A common error is to forget the ForeignFunctionInterface flag
 791     -- so check for that, and suggest.  cf Trac #3805
 792     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
 793     looks_like_foreign (L _ (HsVar v))     = v == foreign_RDR
 794     looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
 795     looks_like_foreign _                   = False
 796
 797     foreign_RDR = mkUnqual varName (fsLit "foreign")
 798
 799 checkDoAndIfThenElse :: LHsExpr RdrName
 800                      -> Bool
 801                      -> LHsExpr RdrName
 802                      -> Bool
 803                      -> LHsExpr RdrName
 804                      -> P ()
 805 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
 806  | semiThen || semiElse
 807     = do pState <- getPState
 808          unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do
 809              parseErrorSDoc (combineLocs guardExpr elseExpr)
 810                             (text "Unexpected semi-colons in conditional:"
 811                           $$ nest 4 expr
 812                           $$ text "Perhaps you meant to use -XDoAndIfThenElse?")
 813  | otherwise            = return ()
 814     where pprOptSemi True  = semi
 815           pprOptSemi False = empty
 816           expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>
 817                  text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>
 818                  text "else" <+> ppr elseExpr
 819 \end{code}
 820
 821
 822 \begin{code}
 823         -- The parser left-associates, so there should
 824         -- not be any OpApps inside the e's
 825 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 826 -- Splits (f ! g a b) into (f, [(! g), a, b])
 827 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
 828   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 829   where
 830     (arg1,argns) = split_bang r_arg []
 831     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 832     split_bang e                 es = (e,es)
 833 splitBang _ = Nothing
 834
 835 isFunLhs :: LHsExpr RdrName
 836          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 837 -- A variable binding is parsed as a FunBind.
 838 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 839 --
 840 -- The whole LHS is parsed as a single expression.
 841 -- Any infix operators on the LHS will parse left-associatively
 842 -- E.g.         f !x y !z
 843 --      will parse (rather strangely) as
 844 --              (f ! x y) ! z
 845 --      It's up to isFunLhs to sort out the mess
 846 --
 847 -- a .!. !b
 848
 849 isFunLhs e = go e []
 850  where
 851    go (L loc (HsVar f)) es
 852         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
 853    go (L _ (HsApp f e)) es       = go f (e:es)
 854    go (L _ (HsPar e))   es@(_:_) = go e es
 855
 856         -- For infix function defns, there should be only one infix *function*
 857         -- (though there may be infix *datacons* involved too).  So we don't
 858         -- need fixity info to figure out which function is being defined.
 859         --      a `K1` b `op` c `K2` d
 860         -- must parse as
 861         --      (a `K1` b) `op` (c `K2` d)
 862         -- The renamer checks later that the precedences would yield such a parse.
 863         --
 864         -- There is a complication to deal with bang patterns.
 865         --
 866         -- ToDo: what about this?
 867         --              x + 1 `op` y = ...
 868
 869    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 870         | Just (e',es') <- splitBang e
 871         = do { bang_on <- extension bangPatEnabled
 872              ; if bang_on then go e' (es' ++ es)
 873                else return (Just (L loc' op, True, (l:r:es))) }
 874                 -- No bangs; behave just like the next case
 875         | not (isRdrDataCon op)         -- We have found the function!
 876         = return (Just (L loc' op, True, (l:r:es)))
 877         | otherwise                     -- Infix data con; keep going
 878         = do { mb_l <- go l es
 879              ; case mb_l of
 880                  Just (op', True, j : k : es')
 881                     -> return (Just (op', True, j : op_app : es'))
 882                     where
 883                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
 884                  _ -> return Nothing }
 885    go _ _ = return Nothing
 886
 887
 888 ---------------------------------------------------------------------------
 889 -- Check for monad comprehensions
 890 --
 891 -- If the flag MonadComprehensions is set, return a `MonadComp' context,
 892 -- otherwise use the usual `ListComp' context
 893
 894 checkMonadComp :: P (HsStmtContext Name)
 895 checkMonadComp = do
 896     pState <- getPState
 897     return $ if xopt Opt_MonadComprehensions (dflags pState)
 898                 then MonadComp
 899                 else ListComp
 900
 901 ---------------------------------------------------------------------------
 902 -- Miscellaneous utilities
 903
 904 checkPrecP :: Located Int -> P Int
 905 checkPrecP (L l i)
 906  | 0 <= i && i <= maxPrecedence = return i
 907  | otherwise
 908     = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
 909
 910 mkRecConstrOrUpdate
 911         :: LHsExpr RdrName
 912         -> SrcSpan
 913         -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
 914         -> P (HsExpr RdrName)
 915
 916 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
 917   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
 918 mkRecConstrOrUpdate exp loc (fs,dd)
 919   | null fs   = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp)
 920   | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
 921
 922 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
 923 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 924 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 925
 926 mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
 927 -- The Maybe is because the user can omit the activation spec (and usually does)
 928 mkInlinePragma (inl, match_info) mb_act
 929   = InlinePragma { inl_inline = inl
 930                  , inl_sat    = Nothing
 931                  , inl_act    = act
 932                  , inl_rule   = match_info }
 933   where
 934     act = case mb_act of
 935             Just act -> act
 936             Nothing  -> -- No phase specified
 937                         case inl of
 938                           NoInline -> NeverActive
 939                           _other   -> AlwaysActive
 940
 941 -----------------------------------------------------------------------------
 942 -- utilities for foreign declarations
 943
 944 -- construct a foreign import declaration
 945 --
 946 mkImport :: CCallConv
 947          -> Safety
 948          -> (Located FastString, Located RdrName, LHsType RdrName)
 949          -> P (HsDecl RdrName)
 950 mkImport cconv safety (L loc entity, v, ty)
 951   | cconv == PrimCallConv                      = do
 952   let funcTarget = CFunction (StaticTarget entity Nothing)
 953       importSpec = CImport PrimCallConv safety nilFS funcTarget
 954   return (ForD (ForeignImport v ty importSpec))
 955
 956   | otherwise = do
 957     case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
 958       Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
 959       Just importSpec -> return (ForD (ForeignImport v ty importSpec))
 960
 961 -- the string "foo" is ambigous: either a header or a C identifier.  The
 962 -- C identifier case comes first in the alternatives below, so we pick
 963 -- that one.
 964 parseCImport :: CCallConv -> Safety -> FastString -> String
 965              -> Maybe ForeignImport
 966 parseCImport cconv safety nm str =
 967  listToMaybe $ map fst $ filter (null.snd) $
 968      readP_to_S parse str
 969  where
 970    parse = do
 971        skipSpaces
 972        r <- choice [
 973           string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
 974           string "wrapper" >> return (mk nilFS CWrapper),
 975           optional (string "static" >> skipSpaces) >>
 976            (mk nilFS <$> cimp nm) +++
 977            (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
 978          ]
 979        skipSpaces
 980        return r
 981
 982    mk = CImport cconv safety
 983
 984    hdr_char c = not (isSpace c) -- header files are filenames, which can contain
 985                                 -- pretty much any char (depending on the platform),
 986                                 -- so just accept any non-space character
 987    id_char  c = isAlphaNum c || c == '_'
 988
 989    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
 990              +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
 991           where
 992             cid = return nm +++
 993                   (do c  <- satisfy (\c -> isAlpha c || c == '_')
 994                       cs <-  many (satisfy id_char)
 995                       return (mkFastString (c:cs)))
 996
 997
 998 -- construct a foreign export declaration
 999 --
1000 mkExport :: CCallConv
1001          -> (Located FastString, Located RdrName, LHsType RdrName)
1002          -> P (HsDecl RdrName)
1003 mkExport cconv (L _ 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
1009 -- Supplying the ext_name in a foreign decl is optional; if it
1010 -- isn't there, the Haskell name is assumed. Note that no transformation
1011 -- of the Haskell name is then performed, so if you foreign export (++),
1012 -- it's external name will be "++". Too bad; it's important because we don't
1013 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1014 --
1015 mkExtName :: RdrName -> CLabelString
1016 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1017 \end{code}
1018
1019
1020 -----------------------------------------------------------------------------
1021 -- Misc utils
1022
1023 \begin{code}
1024 parseError :: SrcSpan -> String -> P a
1025 parseError span s = parseErrorSDoc span (text s)
1026
1027 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1028 parseErrorSDoc span s = failSpanMsgP span s
1029 \end{code}