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