compiler/parser/RdrHsSyn.lhs

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