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