compiler/parser/RdrHsSyn.lhs

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