compiler/parser/RdrHsSyn.lhs

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