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