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         checkDo,              -- [Stmt] -> P [Stmt]
  44         checkMDo,             -- [Stmt] -> P [Stmt]
  45         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  46         checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  47         checkDoAndIfThenElse,
  48         parseError,
  49         parseErrorSDoc,
  50     ) where
  51
  52 import HsSyn            -- Lots of it
  53 import Class            ( FunDep )
  54 import TypeRep          ( Kind )
  55 import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
  56                           isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
  57 import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
  58                           InlinePragma(..) )
  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       HsQuasiQuoteTy {}         -> acc  -- Quasi quotes mention no type variables
 132       HsSpliceTy {}             -> acc  -- Type splices mention no type variables
 133       HsKindSig ty _            -> extract_lty ty acc
 134       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
 135       HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
 136                                            extract_lctxt cx (extract_lty ty []))
 137                                 where
 138                                    locals = hsLTyVarNames tvs
 139       HsDocTy ty _              -> extract_lty ty acc
 140
 141 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
 142 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
 143                       | otherwise     = acc
 144
 145 extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
 146 -- Get the type variables out of the type patterns in a bunch of
 147 -- possibly-generic bindings in a class declaration
 148 extractGenericPatTyVars binds
 149   = nubBy eqLocated (foldrBag get [] binds)
 150   where
 151     get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
 152     get _                                                 acc = acc
 153
 154     get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
 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 statements in a do-expression
 615 --      We parse   do { e1 ; e2 ; }
 616 --      as [ExprStmt e1, ExprStmt e2]
 617 -- checkDo (a) checks that the last thing is an ExprStmt
 618 --         (b) returns it separately
 619 -- same comments apply for mdo as well
 620
 621 checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 622
 623 checkDo  = checkDoMDo "a " "'do'"
 624 checkMDo = checkDoMDo "an " "'mdo'"
 625
 626 checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 627 checkDoMDo _   nm loc []   = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct"))
 628 checkDoMDo pre nm _   ss   = do
 629   check ss
 630   where
 631         check  []                     = panic "RdrHsSyn:checkDoMDo"
 632         check  [L _ (ExprStmt e _ _)] = return ([], e)
 633         check  [L l e] = parseErrorSDoc l
 634                          (text ("The last statement in " ++ pre ++ nm ++
 635                                                     " construct must be an expression:")
 636                        $$ ppr e)
 637         check (s:ss) = do
 638           (ss',e') <-  check ss
 639           return ((s:ss'),e')
 640
 641 -- -------------------------------------------------------------------------
 642 -- Checking Patterns.
 643
 644 -- We parse patterns as expressions and check for valid patterns below,
 645 -- converting the expression into a pattern at the same time.
 646
 647 checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
 648 checkPattern e = checkLPat e
 649
 650 checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
 651 checkPatterns es = mapM checkPattern es
 652
 653 checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
 654 checkLPat e@(L l _) = checkPat l e []
 655
 656 checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
 657 checkPat loc (L l (HsVar c)) args
 658   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
 659 checkPat loc e args     -- OK to let this happen even if bang-patterns
 660                         -- are not enabled, because there is no valid
 661                         -- non-bang-pattern parse of (C ! e)
 662   | Just (e', args') <- splitBang e
 663   = do  { args'' <- checkPatterns args'
 664         ; checkPat loc e' (args'' ++ args) }
 665 checkPat loc (L _ (HsApp f x)) args
 666   = do { x <- checkLPat x; checkPat loc f (x:args) }
 667 checkPat loc (L _ e) []
 668   = do { pState <- getPState
 669        ; p <- checkAPat (dflags pState) loc e
 670        ; return (L loc p) }
 671 checkPat loc e _
 672   = patFail loc (unLoc e)
 673
 674 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
 675 checkAPat dynflags loc e0 = case e0 of
 676    EWildPat -> return (WildPat placeHolderType)
 677    HsVar x  -> return (VarPat x)
 678    HsLit l  -> return (LitPat l)
 679
 680    -- Overloaded numeric patterns (e.g. f 0 x = x)
 681    -- Negation is recorded separately, so that the literal is zero or +ve
 682    -- NB. Negative *primitive* literals are already handled by the lexer
 683    HsOverLit pos_lit          -> return (mkNPat pos_lit Nothing)
 684    NegApp (L _ (HsOverLit pos_lit)) _
 685                         -> return (mkNPat pos_lit (Just noSyntaxExpr))
 686
 687    SectionR (L _ (HsVar bang)) e        -- (! x)
 688         | bang == bang_RDR
 689         -> do { bang_on <- extension bangPatEnabled
 690               ; if bang_on then checkLPat e >>= (return . BangPat)
 691                 else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) }
 692
 693    ELazyPat e         -> checkLPat e >>= (return . LazyPat)
 694    EAsPat n e         -> checkLPat e >>= (return . AsPat n)
 695    -- view pattern is well-formed if the pattern is
 696    EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
 697    ExprWithTySig e t  -> do e <- checkLPat e
 698                             -- Pattern signatures are parsed as sigtypes,
 699                             -- but they aren't explicit forall points.  Hence
 700                             -- we have to remove the implicit forall here.
 701                             let t' = case t of
 702                                        L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
 703                                        other -> other
 704                             return (SigPatIn e t')
 705
 706    -- n+k patterns
 707    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
 708          (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
 709                       | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
 710                       -> return (mkNPlusKPat (L nloc n) lit)
 711
 712    OpApp l op _fix r  -> do l <- checkLPat l
 713                             r <- checkLPat r
 714                             case op of
 715                                L cl (HsVar c) | isDataOcc (rdrNameOcc c)
 716                                       -> return (ConPatIn (L cl c) (InfixCon l r))
 717                                _ -> patFail loc e0
 718
 719    HsPar e            -> checkLPat e >>= (return . ParPat)
 720    ExplicitList _ es  -> do ps <- mapM checkLPat es
 721                             return (ListPat ps placeHolderType)
 722    ExplicitPArr _ es  -> do ps <- mapM checkLPat es
 723                             return (PArrPat ps placeHolderType)
 724
 725    ExplicitTuple es b
 726      | all tupArgPresent es  -> do ps <- mapM checkLPat [e | Present e <- es]
 727                                    return (TuplePat ps b placeHolderType)
 728      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 729
 730    RecordCon c _ (HsRecFields fs dd)
 731                       -> do fs <- mapM checkPatField fs
 732                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
 733    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
 734 -- Generics
 735    HsType ty          -> return (TypePat ty)
 736    _                  -> patFail loc e0
 737
 738 placeHolderPunRhs :: LHsExpr RdrName
 739 -- The RHS of a punned record field will be filled in by the renamer
 740 -- It's better not to make it an error, in case we want to print it when debugging
 741 placeHolderPunRhs = noLoc (HsVar pun_RDR)
 742
 743 plus_RDR, bang_RDR, pun_RDR :: RdrName
 744 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
 745 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
 746 pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
 747
 748 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
 749 checkPatField fld = do  { p <- checkLPat (hsRecFieldArg fld)
 750                         ; return (fld { hsRecFieldArg = p }) }
 751
 752 patFail :: SrcSpan -> HsExpr RdrName -> P a
 753 patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e)
 754
 755
 756 ---------------------------------------------------------------------------
 757 -- Check Equation Syntax
 758
 759 checkValDef :: LHsExpr RdrName
 760             -> Maybe (LHsType RdrName)
 761             -> Located (GRHSs RdrName)
 762             -> P (HsBind RdrName)
 763
 764 checkValDef lhs (Just sig) grhss
 765         -- x :: ty = rhs  parses as a *pattern* binding
 766   = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 767
 768 checkValDef lhs opt_sig grhss
 769   = do  { mb_fun <- isFunLhs lhs
 770         ; case mb_fun of
 771             Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
 772                                                 fun is_infix pats opt_sig grhss
 773             Nothing -> checkPatBind lhs grhss }
 774
 775 checkFunBind :: SrcSpan
 776              -> Located RdrName
 777              -> Bool
 778              -> [LHsExpr RdrName]
 779              -> Maybe (LHsType RdrName)
 780              -> Located (GRHSs RdrName)
 781              -> P (HsBind RdrName)
 782 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 783   = do  ps <- checkPatterns pats
 784         let match_span = combineSrcSpans lhs_loc rhs_span
 785         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 786         -- The span of the match covers the entire equation.
 787         -- That isn't quite right, but it'll do for now.
 788
 789 makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 790 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 791 makeFunBind fn is_infix ms
 792   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
 793               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 794
 795 checkPatBind :: LHsExpr RdrName
 796              -> Located (GRHSs RdrName)
 797              -> P (HsBind RdrName)
 798 checkPatBind lhs (L _ grhss)
 799   = do  { lhs <- checkPattern lhs
 800         ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 801
 802 checkValSig
 803         :: LHsExpr RdrName
 804         -> LHsType RdrName
 805         -> P (Sig RdrName)
 806 checkValSig (L l (HsVar v)) ty
 807   | isUnqual v && not (isDataOcc (rdrNameOcc v))
 808   = return (TypeSig (L l v) ty)
 809 checkValSig lhs@(L l _) ty
 810   = parseErrorSDoc l ((text "Invalid type signature:" <+>
 811                        ppr lhs <+> text "::" <+> ppr ty)
 812                    $$ text hint)
 813   where
 814     hint = if looks_like_foreign lhs
 815            then "Perhaps you meant to use -XForeignFunctionInterface?"
 816            else "Should be of form <variable> :: <type>"
 817     -- A common error is to forget the ForeignFunctionInterface flag
 818     -- so check for that, and suggest.  cf Trac #3805
 819     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
 820     looks_like_foreign (L _ (HsVar v))     = v == foreign_RDR
 821     looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
 822     looks_like_foreign _                   = False
 823
 824     foreign_RDR = mkUnqual varName (fsLit "foreign")
 825
 826 checkDoAndIfThenElse :: LHsExpr RdrName
 827                      -> Bool
 828                      -> LHsExpr RdrName
 829                      -> Bool
 830                      -> LHsExpr RdrName
 831                      -> P ()
 832 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
 833  | semiThen || semiElse
 834     = do pState <- getPState
 835          unless (dopt Opt_DoAndIfThenElse (dflags pState)) $ do
 836              parseErrorSDoc (combineLocs guardExpr elseExpr)
 837                             (text "Unexpected semi-colons in conditional:"
 838                           $$ nest 4 expr
 839                           $$ text "Perhaps you meant to use -XDoAndIfThenElse?")
 840  | otherwise            = return ()
 841     where pprOptSemi True  = semi
 842           pprOptSemi False = empty
 843           expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>
 844                  text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>
 845                  text "else" <+> ppr elseExpr
 846 \end{code}
 847
 848
 849 \begin{code}
 850         -- The parser left-associates, so there should
 851         -- not be any OpApps inside the e's
 852 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 853 -- Splits (f ! g a b) into (f, [(! g), a, b])
 854 splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
 855   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
 856   where
 857     (arg1,argns) = split_bang r_arg []
 858     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
 859     split_bang e                 es = (e,es)
 860 splitBang _ = Nothing
 861
 862 isFunLhs :: LHsExpr RdrName
 863          -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 864 -- A variable binding is parsed as a FunBind.
 865 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 866 --
 867 -- The whole LHS is parsed as a single expression.
 868 -- Any infix operators on the LHS will parse left-associatively
 869 -- E.g.         f !x y !z
 870 --      will parse (rather strangely) as
 871 --              (f ! x y) ! z
 872 --      It's up to isFunLhs to sort out the mess
 873 --
 874 -- a .!. !b
 875
 876 isFunLhs e = go e []
 877  where
 878    go (L loc (HsVar f)) es
 879         | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
 880    go (L _ (HsApp f e)) es       = go f (e:es)
 881    go (L _ (HsPar e))   es@(_:_) = go e es
 882
 883         -- For infix function defns, there should be only one infix *function*
 884         -- (though there may be infix *datacons* involved too).  So we don't
 885         -- need fixity info to figure out which function is being defined.
 886         --      a `K1` b `op` c `K2` d
 887         -- must parse as
 888         --      (a `K1` b) `op` (c `K2` d)
 889         -- The renamer checks later that the precedences would yield such a parse.
 890         --
 891         -- There is a complication to deal with bang patterns.
 892         --
 893         -- ToDo: what about this?
 894         --              x + 1 `op` y = ...
 895
 896    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 897         | Just (e',es') <- splitBang e
 898         = do { bang_on <- extension bangPatEnabled
 899              ; if bang_on then go e' (es' ++ es)
 900                else return (Just (L loc' op, True, (l:r:es))) }
 901                 -- No bangs; behave just like the next case
 902         | not (isRdrDataCon op)         -- We have found the function!
 903         = return (Just (L loc' op, True, (l:r:es)))
 904         | otherwise                     -- Infix data con; keep going
 905         = do { mb_l <- go l es
 906              ; case mb_l of
 907                  Just (op', True, j : k : es')
 908                     -> return (Just (op', True, j : op_app : es'))
 909                     where
 910                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
 911                  _ -> return Nothing }
 912    go _ _ = return Nothing
 913
 914 ---------------------------------------------------------------------------
 915 -- Miscellaneous utilities
 916
 917 checkPrecP :: Located Int -> P Int
 918 checkPrecP (L l i)
 919  | 0 <= i && i <= maxPrecedence = return i
 920  | otherwise
 921     = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
 922
 923 mkRecConstrOrUpdate
 924         :: LHsExpr RdrName
 925         -> SrcSpan
 926         -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
 927         -> P (HsExpr RdrName)
 928
 929 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
 930   = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
 931 mkRecConstrOrUpdate exp loc (fs,dd)
 932   | null fs   = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp)
 933   | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
 934
 935 mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
 936 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 937 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 938
 939 mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
 940 -- The Maybe is because the user can omit the activation spec (and usually does)
 941 mkInlinePragma mb_act match_info inl
 942   = InlinePragma { inl_inline = inl
 943                  , inl_sat    = Nothing
 944                  , inl_act    = act
 945                  , inl_rule   = match_info }
 946   where
 947     act = case mb_act of
 948             Just act -> act
 949             Nothing | inl       -> AlwaysActive
 950                     | otherwise -> NeverActive
 951         -- If no specific phase is given then:
 952         --   NOINLINE => NeverActive
 953         --   INLINE   => Active
 954
 955 -----------------------------------------------------------------------------
 956 -- utilities for foreign declarations
 957
 958 -- construct a foreign import declaration
 959 --
 960 mkImport :: CCallConv
 961          -> Safety
 962          -> (Located FastString, Located RdrName, LHsType RdrName)
 963          -> P (HsDecl RdrName)
 964 mkImport cconv safety (L loc entity, v, ty)
 965   | cconv == PrimCallConv                      = do
 966   let funcTarget = CFunction (StaticTarget entity Nothing)
 967       importSpec = CImport PrimCallConv safety nilFS funcTarget
 968   return (ForD (ForeignImport v ty importSpec))
 969
 970   | otherwise = do
 971     case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
 972       Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
 973       Just importSpec -> return (ForD (ForeignImport v ty importSpec))
 974
 975 -- the string "foo" is ambigous: either a header or a C identifier.  The
 976 -- C identifier case comes first in the alternatives below, so we pick
 977 -- that one.
 978 parseCImport :: CCallConv -> Safety -> FastString -> String
 979              -> Maybe ForeignImport
 980 parseCImport cconv safety nm str =
 981  listToMaybe $ map fst $ filter (null.snd) $
 982      readP_to_S parse str
 983  where
 984    parse = do
 985        skipSpaces
 986        r <- choice [
 987           string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
 988           string "wrapper" >> return (mk nilFS CWrapper),
 989           optional (string "static" >> skipSpaces) >>
 990            (mk nilFS <$> cimp nm) +++
 991            (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
 992          ]
 993        skipSpaces
 994        return r
 995
 996    mk = CImport cconv safety
 997
 998    hdr_char c = not (isSpace c) -- header files are filenames, which can contain
 999                                 -- pretty much any char (depending on the platform),
1000                                 -- so just accept any non-space character
1001    id_char  c = isAlphaNum c || c == '_'
1002
1003    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
1004              +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
1005           where
1006             cid = return nm +++
1007                   (do c  <- satisfy (\c -> isAlpha c || c == '_')
1008                       cs <-  many (satisfy id_char)
1009                       return (mkFastString (c:cs)))
1010
1011
1012 -- construct a foreign export declaration
1013 --
1014 mkExport :: CCallConv
1015          -> (Located FastString, Located RdrName, LHsType RdrName)
1016          -> P (HsDecl RdrName)
1017 mkExport cconv (L _ entity, v, ty) = return $
1018   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
1019   where
1020     entity' | nullFS entity = mkExtName (unLoc v)
1021             | otherwise     = entity
1022
1023 -- Supplying the ext_name in a foreign decl is optional; if it
1024 -- isn't there, the Haskell name is assumed. Note that no transformation
1025 -- of the Haskell name is then performed, so if you foreign export (++),
1026 -- it's external name will be "++". Too bad; it's important because we don't
1027 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
1028 --
1029 mkExtName :: RdrName -> CLabelString
1030 mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
1031 \end{code}
1032
1033
1034 -----------------------------------------------------------------------------
1035 -- Misc utils
1036
1037 \begin{code}
1038 parseError :: SrcSpan -> String -> P a
1039 parseError span s = parseErrorSDoc span (text s)
1040
1041 parseErrorSDoc :: SrcSpan -> SDoc -> P a
1042 parseErrorSDoc span s = failSpanMsgP span s
1043 \end{code}