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