RdrNameGRHS,
RdrNameGRHSs,
RdrNameHsBinds,
+ RdrNameHsCmd,
+ RdrNameHsCmdTop,
RdrNameHsDecl,
RdrNameHsExpr,
RdrNameHsModule,
RdrBinding(..),
RdrMatch(..),
- SigConverter,
- extractHsTyRdrNames, extractHsTyRdrTyVars,
- extractHsCtxtRdrTyVars, extractGenericPatTyVars,
+ main_RDR_Unqual,
+
+ extractHsTyRdrTyVars,
+ extractHsRhoRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
+ mkHsOpApp, mkClassDecl,
mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
- mkHsDo,
+ mkHsDo, mkHsSplice, mkSigDecls,
+ mkTyData, mkPrefixCon, mkRecCon,
+ mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
+ mkBootIface,
cvBinds,
cvMonoBindsAndSigs,
cvTopDecls,
- cvValSig, cvClassOpSig, cvInstDeclSig,
- mkTyData
+ findSplice, addImpDecls, emptyGroup, mkGroup,
+
+ -- Stuff to do with Foreign declarations
+ , CallConv(..)
+ , mkImport -- CallConv -> Safety
+ -- -> (FastString, RdrName, RdrNameHsType)
+ -- -> SrcLoc
+ -- -> P RdrNameHsDecl
+ , mkExport -- CallConv
+ -- -> (FastString, RdrName, RdrNameHsType)
+ -- -> SrcLoc
+ -- -> P RdrNameHsDecl
+ , mkExtName -- RdrName -> CLabelString
+
+ -- Bunch of functions in the parser monad for
+ -- checking and constructing values
+ , checkPrecP -- Int -> P Int
+ , checkContext -- HsType -> P HsContext
+ , checkPred -- HsType -> P HsPred
+ , checkTyVars -- [HsTyVar] -> P [HsType]
+ , checkTyClHdr -- HsType -> (name,[tyvar])
+ , checkInstType -- HsType -> P HsType
+ , checkPattern -- HsExp -> P HsPat
+ , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
+ , checkDo -- [Stmt] -> P [Stmt]
+ , checkMDo -- [Stmt] -> P [Stmt]
+ , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ , parseError -- String -> Pa
) where
#include "HsVersions.h"
import HsSyn -- Lots of it
-import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
- mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
- mkGenOcc2, mkVarOcc
- )
-import PrelNames ( unboundKey )
-import Name ( mkInternalName )
-import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
-import List ( nub )
-import BasicTypes ( RecFlag(..) )
-import SrcLoc ( builtinSrcLoc )
-import Class ( DefMeth (..) )
+import IfaceType
+import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache )
+import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) )
+import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc,
+ isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
+ setRdrNameSpace, rdrNameModule )
+import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
+import Lexer ( P, setSrcLocFor, getSrcLoc, failLocMsgP )
+import HscTypes ( GenAvailInfo(..) )
+import TysWiredIn ( unitTyCon )
+import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
+ DNCallSpec(..), DNKind(..))
+import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
+ occNameUserString, mkVarOcc, isValOcc )
+import BasicTypes ( initialVersion )
+import TyCon ( DataConDetails(..) )
+import Module ( ModuleName )
+import SrcLoc
+import CStrings ( CLabelString )
+import CmdLineOpts ( opt_InPackage )
+import List ( isSuffixOf, nub )
+import Outputable
+import FastString
+import Panic
\end{code}
%************************************************************************
\begin{code}
-type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
+type RdrNameArithSeqInfo = ArithSeqInfo RdrName
type RdrNameBangType = BangType RdrName
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
-type RdrNameConDetails = ConDetails RdrName
+type RdrNameConDetails = HsConDetails RdrName RdrNameBangType
type RdrNameContext = HsContext RdrName
-type RdrNameHsDecl = HsDecl RdrName RdrNamePat
+type RdrNameHsDecl = HsDecl RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
type RdrNameForeignDecl = ForeignDecl RdrName
-type RdrNameGRHS = GRHS RdrName RdrNamePat
-type RdrNameGRHSs = GRHSs RdrName RdrNamePat
-type RdrNameHsBinds = HsBinds RdrName RdrNamePat
-type RdrNameHsExpr = HsExpr RdrName RdrNamePat
-type RdrNameHsModule = HsModule RdrName RdrNamePat
+type RdrNameGRHS = GRHS RdrName
+type RdrNameGRHSs = GRHSs RdrName
+type RdrNameHsBinds = HsBinds RdrName
+type RdrNameHsExpr = HsExpr RdrName
+type RdrNameHsCmd = HsCmd RdrName
+type RdrNameHsCmdTop = HsCmdTop RdrName
+type RdrNameHsModule = HsModule RdrName
type RdrNameIE = IE RdrName
type RdrNameImportDecl = ImportDecl RdrName
-type RdrNameInstDecl = InstDecl RdrName RdrNamePat
-type RdrNameMatch = Match RdrName RdrNamePat
-type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
+type RdrNameInstDecl = InstDecl RdrName
+type RdrNameMatch = Match RdrName
+type RdrNameMonoBinds = MonoBinds RdrName
type RdrNamePat = InPat RdrName
type RdrNameHsType = HsType RdrName
type RdrNameHsTyVar = HsTyVarBndr RdrName
type RdrNameSig = Sig RdrName
-type RdrNameStmt = Stmt RdrName RdrNamePat
-type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
+type RdrNameStmt = Stmt RdrName
+type RdrNameTyClDecl = TyClDecl RdrName
type RdrNameRuleBndr = RuleBndr RdrName
-type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
+type RdrNameRuleDecl = RuleDecl RdrName
type RdrNameDeprecation = DeprecDecl RdrName
type RdrNameFixitySig = FixitySig RdrName
-type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
+type RdrNameHsRecordBinds = HsRecordBinds RdrName
\end{code}
+\begin{code}
+main_RDR_Unqual :: RdrName
+main_RDR_Unqual = mkUnqual varName FSLIT("main")
+ -- We definitely don't want an Orig RdrName, because
+ -- main might, in principle, be imported into module Main
+\end{code}
%************************************************************************
%* *
It's used when making the for-alls explicit.
\begin{code}
-extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
-extractHsTyRdrNames ty = nub (extract_ty ty [])
-
extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
-extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
-extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
-extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
-extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
+extractHsRhoRdrTyVars :: HsContext RdrName -> RdrNameHsType -> [RdrName]
+-- This one takes the context and tau-part of a
+-- sigma type and returns their free type variables
+extractHsRhoRdrTyVars ctxt ty = nub $ filter isRdrTyVar $
+ extract_ctxt ctxt (extract_ty ty [])
extract_ctxt ctxt acc = foldr extract_pred acc ctxt
extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
extract_pred (HsIParam n ty) acc = extract_ty ty acc
-extract_tys tys = foldr extract_ty [] tys
-
-extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (HsListTy ty) acc = extract_ty ty acc
-extract_ty (HsPArrTy ty) acc = extract_ty ty acc
-extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
-extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (HsPredTy p) acc = extract_pred p acc
-extract_ty (HsTyVar tv) acc = tv : acc
-extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
--- Generics
-extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (HsNumTy num) acc = acc
-extract_ty (HsKindSig ty k) acc = extract_ty ty acc
-extract_ty (HsForAllTy (Just tvs) ctxt ty)
+extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsListTy ty) acc = extract_ty ty acc
+extract_ty (HsPArrTy ty) acc = extract_ty ty acc
+extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
+extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsPredTy p) acc = extract_pred p acc
+extract_ty (HsTyVar tv) acc = tv : acc
+extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsParTy ty) acc = extract_ty ty acc
+extract_ty (HsNumTy num) acc = acc
+extract_ty (HsKindSig ty k) acc = extract_ty ty acc
+extract_ty (HsForAllTy exp [] cx ty) acc = extract_ctxt cx (extract_ty ty acc)
+extract_ty (HsForAllTy exp tvs cx ty)
acc = acc ++
(filter (`notElem` locals) $
- extract_ctxt ctxt (extract_ty ty []))
+ extract_ctxt cx (extract_ty ty []))
where
locals = hsTyVarNames tvs
get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
get other acc = acc
- get_m (Match (TypePatIn ty : _) _ _) acc = extract_ty ty acc
- get_m other acc = acc
+ get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc
+ get_m other acc = acc
\end{code}
\begin{code}
mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
= ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
- tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
- tcdSysNames = new_names, tcdLoc = loc }
- where
- cls_occ = rdrNameOcc cname
- data_occ = mkClassDataConOcc cls_occ
- dname = mkRdrUnqual data_occ
- dwname = mkRdrUnqual (mkWorkerOcc data_occ)
- tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
- sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
- | n <- [1..length cxt]]
- -- We number off the superclass selectors, 1, 2, 3 etc so that we
- -- can construct names for the selectors. Thus
- -- class (C a, C b) => D a b where ...
- -- gives superclass selectors
- -- D_sc1, D_sc2
- -- (We used to call them D_C, but now we can have two different
- -- superclasses both called C!)
- new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
+ tcdFDs = fds,
+ tcdSigs = sigs,
+ tcdMeths = mbinds,
+ tcdLoc = loc }
mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
- = let t_occ = rdrNameOcc tname
- name1 = mkRdrUnqual (mkGenOcc1 t_occ)
- name2 = mkRdrUnqual (mkGenOcc2 t_occ)
- in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
- tcdTyVars = tyvars, tcdCons = data_cons,
- tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
-
-mkClassOpSigDM op ty loc
- = ClassOpSig op (DefMeth dm_rn) ty loc
- where
- dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
-
-mkConDecl cname ex_vars cxt details loc
- = ConDecl cname wkr_name ex_vars cxt details loc
- where
- wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
+ = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
+ tcdTyVars = tyvars, tcdCons = data_cons,
+ tcdDerivs = maybe, tcdLoc = src }
\end{code}
\begin{code}
mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
-mkHsNegApp expr = NegApp expr placeHolderName
+mkHsNegApp expr = NegApp expr placeHolderName
\end{code}
A useful function for building @OpApps@. The operator is always a
mkHsFractional f = HsFractional f placeHolderName
mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
+\end{code}
+
+\begin{code}
+mkHsSplice e loc = HsSplice unqualSplice e loc
+
+unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
+ -- A name (uniquified later) to
+ -- identify the splice
+\end{code}
+
+%************************************************************************
+%* *
+ Hi-boot files
+%* *
+%************************************************************************
+
+mkBootIface, and its boring helper functions, have two purposes:
+a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
+ an hi-boot file, and interfaces consist of the latter
+b) Convert unqualifed names from the "current module" to qualified Orig
+ names. E.g.
+ module This where
+ foo :: GHC.Base.Int -> GHC.Base.Int
+ becomes
+ This.foo :: GHC.Base.Int -> GHC.Base.Int
+
+It assumes that everything is well kinded, of course.
-placeHolderName = mkInternalName unboundKey
- (mkVarOcc FSLIT("syntaxPlaceHolder"))
- builtinSrcLoc
+\begin{code}
+mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
+-- Make the ModIface for a hi-boot file
+-- The decls are of very limited form
+mkBootIface mod decls
+ = (emptyModIface opt_InPackage mod) {
+ mi_boot = True,
+ mi_exports = [(mod, map mk_export decls')],
+ mi_decls = decls_w_vers,
+ mi_ver_fn = mkIfaceVerCache decls_w_vers }
+ where
+ decls' = map hsIfaceDecl decls
+ decls_w_vers = repeat initialVersion `zip` decls'
+
+ -- hi-boot declarations don't (currently)
+ -- expose constructors or class methods
+ mk_export decl | isValOcc occ = Avail occ
+ | otherwise = AvailTC occ [occ]
+ where
+ occ = ifName decl
+
+
+hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
+ -- Change to Iface syntax, and replace unqualified names with
+ -- qualified Orig names from this module. Reason: normal
+ -- iface files have everything fully qualified, so it's convenient
+ -- for hi-boot files to look the same
+ --
+ -- NB: no constructors or class ops to worry about
+hsIfaceDecl (SigD (Sig name ty _))
+ = IfaceId { ifName = rdrNameOcc name,
+ ifType = hsIfaceType ty,
+ ifIdInfo = NoInfo }
+
+hsIfaceDecl (TyClD decl@(TySynonym {}))
+ = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifSynRhs = hsIfaceType (tcdSynRhs decl),
+ ifVrcs = [] }
+
+hsIfaceDecl (TyClD decl@(TyData {}))
+ = IfaceData { ifND = tcdND decl,
+ ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifCtxt = hsIfaceCtxt (tcdCtxt decl),
+ ifCons = Unknown, ifRec = NonRecursive,
+ ifVrcs = [], ifGeneric = False }
+ -- I'm not sure that [] is right for ifVrcs, but
+ -- since we don't use them I'm not going to fiddle
+
+hsIfaceDecl (TyClD decl@(ClassDecl {}))
+ = IfaceClass { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifCtxt = hsIfaceCtxt (tcdCtxt decl),
+ ifFDs = hsIfaceFDs (tcdFDs decl),
+ ifSigs = [], -- Is this right??
+ ifRec = NonRecursive, ifVrcs = [] }
+
+hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
+
+hsIfaceName rdr_name -- Qualify unqualifed occurrences
+ -- with the module name
+ | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
+ | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+
+hsIfaceType :: HsType RdrName -> IfaceType
+hsIfaceType (HsForAllTy exp tvs cxt ty)
+ = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
+ where
+ rho = foldr (IfaceFunTy . IfacePredTy . hsIfacePred) tau cxt
+ tau = hsIfaceType ty
+ tvs' = case exp of
+ Explicit -> tvs
+ Implicit -> map UserTyVar (extractHsRhoRdrTyVars cxt ty)
+
+hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
+hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
+hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceType t1) (hsIfaceType t2)
+hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceType t]
+hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceType t]
+hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceTypes ts)
+hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar tc) (hsIfaceTypes [t1, t2])
+hsIfaceType (HsParTy t) = hsIfaceType t
+hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
+hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
+hsIfaceType (HsKindSig t _) = hsIfaceType t
+
+-----------
+hsIfaceTypes tys = map hsIfaceType tys
+
+-----------
+hsIfaceCtxt :: [HsPred RdrName] -> [IfacePredType]
+hsIfaceCtxt ctxt = map hsIfacePred ctxt
+
+-----------
+hsIfacePred :: HsPred RdrName -> IfacePredType
+hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceTypes ts)
+hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceType t)
+
+-----------
+hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
+hs_tc_app (HsAppTy t1 t2) args = hs_tc_app t1 (hsIfaceType t2 : args)
+hs_tc_app (HsTyVar n) args
+ | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
+ | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
+hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
+
+-----------
+hsIfaceTvs tvs = map hsIfaceTv tvs
+
+-----------
+hsIfaceTv (UserTyVar n) = (rdrNameOcc n, IfaceLiftedTypeKind)
+hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k)
+
+-----------
+hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
+hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
+ | (xs,ys) <- fds ]
\end{code}
\begin{code}
data RdrBinding
- = -- On input we use the Empty/And form rather than a list
- RdrNullBind
- | RdrAndBindings RdrBinding RdrBinding
-
- -- Value bindings havn't been united with their
+ = -- Value bindings havn't been united with their
-- signatures yet
- | RdrValBinding RdrNameMonoBinds
+ RdrBindings [RdrBinding] -- Convenience for parsing
- -- Signatures are mysterious; we can't
- -- tell if its a Sig or a ClassOpSig,
- -- so we just save the pieces:
- | RdrSig RdrNameSig
+ | RdrValBinding RdrNameMonoBinds
-- The remainder all fit into the main HsDecl form
| RdrHsDecl RdrNameHsDecl
-
-type SigConverter = RdrNameSig -> RdrNameSig
\end{code}
\begin{code}
%************************************************************************
%* *
-\subsection[cvDecls]{Convert various top-level declarations}
-%* *
-%************************************************************************
-
-We make a point not to throw any user-pragma ``sigs'' at
-these conversion functions:
-
-\begin{code}
-cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
-
-cvValSig sig = sig
-
-cvInstDeclSig sig = sig
-
-cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
-cvClassOpSig sig = sig
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
%* *
%************************************************************************
initially, and non recursive definitions are discovered by the dependency
analyser.
-\begin{code}
-cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
- -- The mysterious SigConverter converts Sigs to ClassOpSigs
- -- in class declarations. Mostly it's just an identity function
-cvBinds sig_cvtr binding
- = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
+\begin{code}
+cvTopDecls :: [RdrBinding] -> [RdrNameHsDecl]
+-- Incoming bindings are in reverse order; result is in ordinary order
+-- (a) flatten RdrBindings
+-- (b) Group together bindings for a single function
+cvTopDecls decls
+ = go [] decls
+ where
+ go :: [RdrNameHsDecl] -> [RdrBinding] -> [RdrNameHsDecl]
+ go acc [] = acc
+ go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2
+ go acc (RdrHsDecl d : ds) = go (d : acc) ds
+ go acc (RdrValBinding b : ds) = go (ValD b' : acc) ds'
+ where
+ (b', ds') = getMonoBind b ds
+
+cvBinds :: [RdrBinding] -> RdrNameHsBinds
+cvBinds binding
+ = case (cvMonoBindsAndSigs binding) of { (mbs, sigs) ->
MonoBind mbs sigs Recursive
}
-\end{code}
-\begin{code}
-cvMonoBindsAndSigs :: SigConverter
- -> RdrBinding
- -> (RdrNameMonoBinds, [RdrNameSig])
+cvMonoBindsAndSigs :: [RdrBinding] -> (RdrNameMonoBinds, [RdrNameSig])
+-- Input bindings are in *reverse* order,
+-- and contain just value bindings and signatuers
-cvMonoBindsAndSigs sig_cvtr fb
- = mangle_bind (EmptyMonoBinds, []) fb
+cvMonoBindsAndSigs fb
+ = go (EmptyMonoBinds, []) fb
where
- mangle_bind acc RdrNullBind
- = acc
-
- mangle_bind acc (RdrAndBindings fb1 fb2)
- = mangle_bind (mangle_bind acc fb1) fb2
-
- mangle_bind (b_acc, s_acc) (RdrSig sig)
- = (b_acc, sig_cvtr sig : s_acc)
-
- mangle_bind (b_acc, s_acc) (RdrValBinding binding)
- = (b_acc `AndMonoBinds` binding, s_acc)
+ go acc [] = acc
+ go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2
+ go (bs, ss) (RdrHsDecl (SigD s) : ds) = go (bs, s : ss) ds
+ go (bs, ss) (RdrValBinding b : ds) = go (b' `AndMonoBinds` bs, ss) ds'
+ where
+ (b',ds') = getMonoBind b ds
+
+-----------------------------------------------------------------------------
+-- Group function bindings into equation groups
+
+getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBinding])
+-- Suppose (b',ds') = getMonoBind b ds
+-- ds is a *reversed* list of parsed bindings
+-- b is a MonoBinds that has just been read off the front
+
+-- Then b' is the result of grouping more equations from ds that
+-- belong with b into a single MonoBinds, and ds' is the depleted
+-- list of parsed bindings.
+--
+-- No AndMonoBinds or EmptyMonoBinds here; just single equations
+
+getMonoBind (FunMonoBind f inf mtchs loc) binds
+ | has_args mtchs
+ = go mtchs loc binds
+ where
+ go mtchs1 loc1 (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds)
+ | f == f2 = go (mtchs2 ++ mtchs1) loc2 binds
+ -- Remember binds is reversed, so glue mtchs2 on the front
+ -- and use loc2 as the final location
+ go mtchs1 loc1 binds = (FunMonoBind f inf mtchs1 loc1, binds)
+
+getMonoBind bind binds = (bind, binds)
+
+has_args ((Match args _ _) : _) = not (null args)
+ -- Don't group together FunMonoBinds if they have
+ -- no arguments. This is necessary now that variable bindings
+ -- with no arguments are now treated as FunMonoBinds rather
+ -- than pattern bindings (tests/rename/should_fail/rnfail002).
\end{code}
+\begin{code}
+emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive,
+ -- The renamer adds structure to the bindings;
+ -- they start life as a single giant MonoBinds
+ hs_tyclds = [], hs_instds = [],
+ hs_fixds = [], hs_defds = [], hs_fords = [],
+ hs_depds = [] ,hs_ruleds = [] }
+
+findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
+findSplice ds = add emptyGroup ds
+
+mkGroup :: [HsDecl a] -> HsGroup a
+mkGroup ds = addImpDecls emptyGroup ds
+
+addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a
+-- The decls are imported, and should not have a splice
+addImpDecls group decls = case add group decls of
+ (group', Nothing) -> group'
+ other -> panic "addImpDecls"
+
+add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
+ -- This stuff reverses the declarations (again) but it doesn't matter
+
+-- Base cases
+add gp [] = (gp, Nothing)
+add gp (SpliceD e : ds) = (gp, Just (e, ds))
+
+-- Class declarations: pull out the fixity signatures to the top
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds)
+ | isClassDecl d = add (gp { hs_tyclds = d : ts,
+ hs_fixds = [f | FixSig f <- tcdSigs d] ++ fs }) ds
+ | otherwise = add (gp { hs_tyclds = d : ts }) ds
+
+-- Signatures: fixity sigs go a different place than all others
+add gp@(HsGroup {hs_fixds = ts}) (SigD (FixSig f) : ds) = add (gp {hs_fixds = f : ts}) ds
+add gp@(HsGroup {hs_valds = ts}) (SigD d : ds) = add (gp {hs_valds = add_sig d ts}) ds
+
+-- Value declarations: use add_bind
+add gp@(HsGroup {hs_valds = ts}) (ValD d : ds) = add (gp { hs_valds = add_bind d ts }) ds
+
+-- The rest are routine
+add gp@(HsGroup {hs_instds = ts}) (InstD d : ds) = add (gp { hs_instds = d : ts }) ds
+add gp@(HsGroup {hs_defds = ts}) (DefD d : ds) = add (gp { hs_defds = d : ts }) ds
+add gp@(HsGroup {hs_fords = ts}) (ForD d : ds) = add (gp { hs_fords = d : ts }) ds
+add gp@(HsGroup {hs_depds = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds
+add gp@(HsGroup {hs_ruleds = ts})(RuleD d : ds) = add (gp { hs_ruleds = d : ts }) ds
+
+add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r
+add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r
+\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
-Separate declarations into all the various kinds:
\begin{code}
-cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
-cvTopDecls bind
- = let
- (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
- in
- (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
+-----------------------------------------------------------------------------
+-- mkPrefixCon
+
+-- When parsing data declarations, we sometimes inadvertently parse
+-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
+-- This function splits up the type application, adds any pending
+-- arguments, and converts the type constructor back into a data constructor.
+
+mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
+
+mkPrefixCon ty tys
+ = split ty tys
+ where
+ split (HsAppTy t u) ts = split t (unbangedType u : ts)
+ split (HsTyVar tc) ts = tyConToDataCon tc >>= \ data_con ->
+ return (data_con, PrefixCon ts)
+ split _ _ = parseError "Illegal data/newtype declaration"
+
+mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
+mkRecCon con fields
+ = tyConToDataCon con >>= \ data_con ->
+ return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
+
+tyConToDataCon :: RdrName -> P RdrName
+tyConToDataCon tc
+ | isTcOcc (rdrNameOcc tc)
+ = return (setRdrNameSpace tc srcDataName)
+ | otherwise
+ = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
+
+----------------------------------------------------------------------------
+-- Various Syntactic Checks
+
+checkInstType :: RdrNameHsType -> P RdrNameHsType
+checkInstType t
+ = case t of
+ HsForAllTy exp tvs ctxt ty ->
+ checkDictTy ty [] >>= \ dict_ty ->
+ return (HsForAllTy exp tvs ctxt dict_ty)
+
+ HsParTy ty -> checkInstType ty
+
+ ty -> checkDictTy ty [] >>= \ dict_ty->
+ return (HsForAllTy Implicit [] [] dict_ty)
+
+checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
+checkTyVars tvs
+ = mapM chk tvs
+ where
+ -- Check that the name space is correct!
+ chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = return (KindedTyVar tv k)
+ chk (HsTyVar tv) | isRdrTyVar tv = return (UserTyVar tv)
+ chk other = parseError "Type found where type variable expected"
+
+checkTyClHdr :: RdrNameContext -> RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
+-- The header of a type or class decl should look like
+-- (C a, D b) => T a b
+-- or T a b
+-- or a + b
+-- etc
+checkTyClHdr cxt ty
+ = go ty [] >>= \ (tc, tvs) ->
+ mapM chk_pred cxt >>= \ _ ->
+ return (cxt, tc, tvs)
where
- go acc RdrNullBind = acc
- go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
- go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
- go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
- go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
- go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)
+ go (HsTyVar tc) acc
+ | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
+ return (tc, tvs)
+ go (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
+ return (tc, tvs)
+ go (HsParTy ty) acc = go ty acc
+ go (HsAppTy t1 t2) acc = go t1 (t2:acc)
+ go other acc = parseError "Malformed LHS to type of class declaration"
+
+ -- The predicates in a type or class decl must all
+ -- be HsClassPs. They need not all be type variables,
+ -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
+ chk_pred (HsClassP _ args) = return ()
+ chk_pred pred = parseError "Malformed context in type or class declaration"
+
+
+checkContext :: RdrNameHsType -> P RdrNameContext
+checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
+ = mapM checkPred ts
+
+checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way
+ = checkContext ty
+
+checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
+ | t == getRdrName unitTyCon = return []
+
+checkContext t
+ = checkPred t >>= \p ->
+ return [p]
+
+checkPred :: RdrNameHsType -> P (HsPred RdrName)
+-- Watch out.. in ...deriving( Show )... we use checkPred on
+-- the list of partially applied predicates in the deriving,
+-- so there can be zero args.
+checkPred (HsPredTy (HsIParam n ty)) = return (HsIParam n ty)
+checkPred ty
+ = go ty []
+ where
+ go (HsTyVar t) args | not (isRdrTyVar t)
+ = return (HsClassP t args)
+ go (HsAppTy l r) args = go l (r:args)
+ go (HsParTy t) args = go t args
+ go _ _ = parseError "Illegal class assertion"
+
+checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
+checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
+ = return (mkHsDictTy t args)
+checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
+checkDictTy (HsParTy t) args = checkDictTy t args
+checkDictTy _ _ = parseError "Malformed context in instance header"
+
+
+---------------------------------------------------------------------------
+-- Checking statements in a do-expression
+-- We parse do { e1 ; e2 ; }
+-- as [ExprStmt e1, ExprStmt e2]
+-- checkDo (a) checks that the last thing is an ExprStmt
+-- (b) transforms it to a ResultStmt
+-- same comments apply for mdo as well
+
+checkDo = checkDoMDo "a " "'do'"
+checkMDo = checkDoMDo "an " "'mdo'"
+
+checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct"
+checkDoMDo _ _ [ExprStmt e _ l] = return [ResultStmt e l]
+checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
+checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss >>= \ ss' ->
+ return (s:ss')
+
+-- -------------------------------------------------------------------------
+-- Checking Patterns.
+
+-- We parse patterns as expressions and check for valid patterns below,
+-- converting the expression into a pattern at the same time.
+
+checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
+checkPattern loc e = setSrcLocFor loc (checkPat e [])
+
+checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
+checkPatterns loc es = mapM (checkPattern loc) es
+
+checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
+checkPat (HsVar c) args | isRdrDataCon c = return (ConPatIn c (PrefixCon args))
+checkPat (HsApp f x) args =
+ checkPat x [] >>= \x ->
+ checkPat f (x:args)
+checkPat e [] = case e of
+ EWildPat -> return (WildPat placeHolderType)
+ HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x)
+ | otherwise -> return (VarPat x)
+ HsLit l -> return (LitPat l)
+
+ -- Overloaded numeric patterns (e.g. f 0 x = x)
+ -- Negation is recorded separately, so that the literal is zero or +ve
+ -- NB. Negative *primitive* literals are already handled by
+ -- RdrHsSyn.mkHsNegApp
+ HsOverLit pos_lit -> return (NPatIn pos_lit Nothing)
+ NegApp (HsOverLit pos_lit) _ -> return (NPatIn pos_lit (Just placeHolderName))
+
+ ELazyPat e -> checkPat e [] >>= (return . LazyPat)
+ EAsPat n e -> checkPat e [] >>= (return . AsPat n)
+ ExprWithTySig e t -> checkPat e [] >>= \e ->
+ -- Pattern signatures are parsed as sigtypes,
+ -- but they aren't explicit forall points. Hence
+ -- we have to remove the implicit forall here.
+ let t' = case t of
+ HsForAllTy Implicit _ [] ty -> ty
+ other -> other
+ in
+ return (SigPatIn e t')
+
+ -- n+k patterns
+ OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
+ | plus == plus_RDR
+ -> return (mkNPlusKPat n lit)
+ where
+ plus_RDR = mkUnqual varName FSLIT("+") -- Hack
+
+ OpApp l op fix r -> checkPat l [] >>= \l ->
+ checkPat r [] >>= \r ->
+ case op of
+ HsVar c | isDataOcc (rdrNameOcc c)
+ -> return (ConPatIn c (InfixCon l r))
+ _ -> patFail
+
+ HsPar e -> checkPat e [] >>= (return . ParPat)
+ ExplicitList _ es -> mapM (\e -> checkPat e []) es >>= \ps ->
+ return (ListPat ps placeHolderType)
+ ExplicitPArr _ es -> mapM (\e -> checkPat e []) es >>= \ps ->
+ return (PArrPat ps placeHolderType)
+
+ ExplicitTuple es b -> mapM (\e -> checkPat e []) es >>= \ps ->
+ return (TuplePat ps b)
+
+ RecordCon c fs -> mapM checkPatField fs >>= \fs ->
+ return (ConPatIn c (RecCon fs))
+-- Generics
+ HsType ty -> return (TypePat ty)
+ _ -> patFail
+
+checkPat _ _ = patFail
+
+checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
+checkPatField (n,e) = checkPat e [] >>= \p ->
+ return (n,p)
+
+patFail = parseError "Parse error in pattern"
+
+
+---------------------------------------------------------------------------
+-- Check Equation Syntax
+
+checkValDef
+ :: RdrNameHsExpr
+ -> Maybe RdrNameHsType
+ -> RdrNameGRHSs
+ -> SrcLoc
+ -> P RdrBinding
+
+checkValDef lhs opt_sig grhss loc
+ = case isFunLhs lhs [] of
+ Just (f,inf,es)
+ | isQual f
+ -> parseError ("Qualified name in function definition: " ++ showRdrName f)
+ | otherwise
+ -> checkPatterns loc es >>= \ps ->
+ return (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
+
+ Nothing ->
+ checkPattern loc lhs >>= \lhs ->
+ return (RdrValBinding (PatMonoBind lhs grhss loc))
+
+checkValSig
+ :: RdrNameHsExpr
+ -> RdrNameHsType
+ -> SrcLoc
+ -> P RdrBinding
+checkValSig (HsVar v) ty loc | isUnqual v = return (RdrHsDecl (SigD (Sig v ty loc)))
+checkValSig other ty loc = parseError "Type signature given for an expression"
+
+mkSigDecls :: [Sig RdrName] -> RdrBinding
+mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs]
+
+
+-- A variable binding is parsed as an RdrNameFunMonoBind.
+-- See comments with HsBinds.MonoBinds
+
+isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
+isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
+ = Just (op, True, (l:r:es))
+ | otherwise
+ = case isFunLhs l es of
+ Just (op', True, j : k : es') ->
+ Just (op', True, j : OpApp k (HsVar op) fix r : es')
+ _ -> Nothing
+isFunLhs (HsVar f) es | not (isRdrDataCon f)
+ = Just (f,False,es)
+isFunLhs (HsApp f e) es = isFunLhs f (e:es)
+isFunLhs (HsPar e) es@(_:_) = isFunLhs e es
+isFunLhs _ _ = Nothing
+
+---------------------------------------------------------------------------
+-- Miscellaneous utilities
+
+checkPrecP :: Int -> P Int
+checkPrecP i | 0 <= i && i <= maxPrecedence = return i
+ | otherwise = parseError "Precedence out of range"
+
+mkRecConstrOrUpdate
+ :: RdrNameHsExpr
+ -> RdrNameHsRecordBinds
+ -> P RdrNameHsExpr
+
+mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
+ = return (RecordCon c fs)
+mkRecConstrOrUpdate exp fs@(_:_)
+ = return (RecordUpd exp fs)
+mkRecConstrOrUpdate _ _
+ = parseError "Empty record update"
+
+-----------------------------------------------------------------------------
+-- utilities for foreign declarations
+
+-- supported calling conventions
+--
+data CallConv = CCall CCallConv -- ccall or stdcall
+ | DNCall -- .NET
+
+-- construct a foreign import declaration
+--
+mkImport :: CallConv
+ -> Safety
+ -> (FastString, RdrName, RdrNameHsType)
+ -> SrcLoc
+ -> P RdrNameHsDecl
+mkImport (CCall cconv) safety (entity, v, ty) loc =
+ parseCImport entity cconv safety v >>= \importSpec ->
+ return $ ForD (ForeignImport v ty importSpec False loc)
+mkImport (DNCall ) _ (entity, v, ty) loc =
+ parseDImport entity >>= \ spec ->
+ return $ ForD (ForeignImport v ty (DNImport spec) False loc)
+
+-- parse the entity string of a foreign import declaration for the `ccall' or
+-- `stdcall' calling convention'
+--
+parseCImport :: FastString
+ -> CCallConv
+ -> Safety
+ -> RdrName
+ -> P ForeignImport
+parseCImport entity cconv safety v
+ -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
+ | entity == FSLIT ("dynamic") =
+ return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
+ | entity == FSLIT ("wrapper") =
+ return $ CImport cconv safety nilFS nilFS CWrapper
+ | otherwise = parse0 (unpackFS entity)
+ where
+ -- using the static keyword?
+ parse0 (' ': rest) = parse0 rest
+ parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
+ parse0 rest = parse1 rest
+ -- check for header file name
+ parse1 "" = parse4 "" nilFS False nilFS
+ parse1 (' ':rest) = parse1 rest
+ parse1 str@('&':_ ) = parse2 str nilFS
+ parse1 str@('[':_ ) = parse3 str nilFS False
+ parse1 str
+ | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
+ | otherwise = parse4 str nilFS False nilFS
+ where
+ (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
+ -- check for address operator (indicating a label import)
+ parse2 "" header = parse4 "" header False nilFS
+ parse2 (' ':rest) header = parse2 rest header
+ parse2 ('&':rest) header = parse3 rest header True
+ parse2 str@('[':_ ) header = parse3 str header False
+ parse2 str header = parse4 str header False nilFS
+ -- check for library object name
+ parse3 (' ':rest) header isLbl = parse3 rest header isLbl
+ parse3 ('[':rest) header isLbl =
+ case break (== ']') rest of
+ (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
+ _ -> parseError "Missing ']' in entity"
+ parse3 str header isLbl = parse4 str header isLbl nilFS
+ -- check for name of C function
+ parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib
+ parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
+ parse4 str header isLbl lib
+ | all (== ' ') rest = build (mkFastString first) header isLbl lib
+ | otherwise = parseError "Malformed entity string"
+ where
+ (first, rest) = break (== ' ') str
+ --
+ build cid header False lib = return $
+ CImport cconv safety header lib (CFunction (StaticTarget cid))
+ build cid header True lib = return $
+ CImport cconv safety header lib (CLabel cid )
+
+--
+-- Unravel a dotnet spec string.
+--
+parseDImport :: FastString -> P DNCallSpec
+parseDImport entity = parse0 comps
+ where
+ comps = words (unpackFS entity)
+
+ parse0 [] = d'oh
+ parse0 (x : xs)
+ | x == "static" = parse1 True xs
+ | otherwise = parse1 False (x:xs)
+
+ parse1 _ [] = d'oh
+ parse1 isStatic (x:xs)
+ | x == "method" = parse2 isStatic DNMethod xs
+ | x == "field" = parse2 isStatic DNField xs
+ | x == "ctor" = parse2 isStatic DNConstructor xs
+ parse1 isStatic xs = parse2 isStatic DNMethod xs
+
+ parse2 _ _ [] = d'oh
+ parse2 isStatic kind (('[':x):xs) =
+ case x of
+ [] -> d'oh
+ vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
+ parse2 isStatic kind xs = parse3 isStatic kind "" xs
+
+ parse3 isStatic kind assem [x] =
+ return (DNCallSpec isStatic kind assem x
+ -- these will be filled in once known.
+ (error "FFI-dotnet-args")
+ (error "FFI-dotnet-result"))
+ parse3 _ _ _ _ = d'oh
+
+ d'oh = parseError "Malformed entity string"
+
+-- construct a foreign export declaration
+--
+mkExport :: CallConv
+ -> (FastString, RdrName, RdrNameHsType)
+ -> SrcLoc
+ -> P RdrNameHsDecl
+mkExport (CCall cconv) (entity, v, ty) loc = return $
+ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
+ where
+ entity' | nullFastString entity = mkExtName v
+ | otherwise = entity
+mkExport DNCall (entity, v, ty) loc =
+ parseError "Foreign export is not yet supported for .NET"
+
+-- Supplying the ext_name in a foreign decl is optional; if it
+-- isn't there, the Haskell name is assumed. Note that no transformation
+-- of the Haskell name is then performed, so if you foreign export (++),
+-- it's external name will be "++". Too bad; it's important because we don't
+-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
+-- (This is why we use occNameUserString.)
+--
+mkExtName :: RdrName -> CLabelString
+mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
+\end{code}
+
+
+-----------------------------------------------------------------------------
+-- Misc utils
+
+\begin{code}
+showRdrName :: RdrName -> String
+showRdrName r = showSDoc (ppr r)
+
+parseError :: String -> P a
+parseError s =
+ getSrcLoc >>= \ loc ->
+ failLocMsgP loc loc s
\end{code}
projects / ghc-hetmet.git / blobdiff