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