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