RdrNameGRHS,
RdrNameGRHSs,
RdrNameHsBinds,
+ RdrNameHsCmd,
+ RdrNameHsCmdTop,
RdrNameHsDecl,
RdrNameHsExpr,
RdrNameHsModule,
RdrBinding(..),
RdrMatch(..),
+ main_RDR_Unqual,
+
extractHsTyRdrNames, extractHsTyRdrTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl, mkClassOpSigDM,
+ mkHsOpApp, mkClassDecl,
mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
mkHsDo, mkHsSplice, mkSigDecls,
mkTyData, mkPrefixCon, mkRecCon,
cvBinds,
cvMonoBindsAndSigs,
cvTopDecls,
- cvClassOpSig,
findSplice, addImpDecls, emptyGroup, mkGroup,
-- Stuff to do with Foreign declarations
import HscTypes ( RdrAvailInfo, GenAvailInfo(..) )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
- DNCallSpec(..))
-import OccName ( dataName, varName, isDataOcc, isTcOcc, occNameUserString,
+ DNCallSpec(..), DNKind(..))
+import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString,
mkDefaultMethodOcc, mkVarOcc )
import SrcLoc
import CStrings ( CLabelString )
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 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}
%************************************************************************
%* *
\begin{code}
mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
= ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
- tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
+ tcdFDs = fds,
+ tcdSigs = map cvClassOpSig sigs, -- Convert to class-op sigs
+ tcdMeths = mbinds,
tcdLoc = loc }
mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
tcdTyVars = tyvars, tcdCons = data_cons,
tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing }
-mkClassOpSigDM op ty loc
- = ClassOpSig op (DefMeth dm_rn) ty loc
+cvClassOpSig :: RdrNameSig -> RdrNameSig
+cvClassOpSig (Sig var poly_ty src_loc)
+ = ClassOpSig var (DefMeth dm_rn) poly_ty src_loc
where
- dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
+ dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc var))
+cvClassOpSig sig
+ = sig
\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}
-cvClassOpSig :: RdrNameSig -> RdrNameSig
-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.}
%* *
%************************************************************************
tyConToDataCon :: RdrName -> P RdrName
tyConToDataCon tc
| isTcOcc (rdrNameOcc tc)
- = returnP (setRdrNameSpace tc dataName)
+ = returnP (setRdrNameSpace tc srcDataName)
| otherwise
= parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
returnP (HsForAllTy Nothing [] dict_ty)
checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
-checkTyVars tvs = mapP chk tvs
- where
- chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k)
- chk (HsTyVar tv) = returnP (UserTyVar tv)
- chk other = parseError "Type found where type variable expected"
+checkTyVars tvs
+ = mapP chk tvs
+ where
+ -- Check that the name space is correct!
+ chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = returnP (IfaceTyVar tv k)
+ chk (HsTyVar tv) | isRdrTyVar tv = returnP (UserTyVar tv)
+ chk other = parseError "Type found where type variable expected"
checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
-- The header of a type or class decl should look like
parseCImport entity cconv safety v `thenP` \importSpec ->
returnP $ ForD (ForeignImport v ty importSpec False loc)
mkImport (DNCall ) _ (entity, v, ty) loc =
- returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
+ parseDImport entity `thenP` \ spec ->
+ returnP $ ForD (ForeignImport v ty (DNImport spec) False loc)
-- parse the entity string of a foreign import declaration for the `ccall' or
-- `stdcall' calling convention'
build cid header True lib = returnP $
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] =
+ returnP (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
projects / ghc-hetmet.git / blobdiff