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