X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FConvert.lhs;h=5098901a346a573b24a6978a3731439867e0ef0e;hb=bfc3c306e8ed18f3d5ccebda94a38e89316f5b00;hp=2135d18d1856004f6d63b2873fe0dd1607ab8079;hpb=cb51a09231da94d729bcd62177cbdec1a888a180;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 2135d18..5098901 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -14,14 +14,14 @@ import Language.Haskell.THSyntax as Meta import HsSyn as Hs ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - HsStmtContext(..), TyClDecl(..), + HsStmtContext(..), TyClDecl(..), HsBang(..), Match(..), GRHSs(..), GRHS(..), HsPred(..), HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..), Stmt(..), HsBinds(..), MonoBinds(..), Sig(..), Pat(..), HsConDetails(..), HsOverLit, BangType(..), - placeHolderType, HsType(..), HsTupCon(..), + placeHolderType, HsType(..), HsExplicitForAll(..), HsTyVarBndr(..), HsContext, - mkSimpleMatch, mkHsForAllTy + mkSimpleMatch, mkImplicitHsForAllTy, mkExplicitHsForAllTy ) import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig ) @@ -29,12 +29,12 @@ import Module ( mkModuleName ) import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData ) import OccName import SrcLoc ( SrcLoc, generatedSrcLoc ) -import TyCon ( DataConDetails(..) ) import Type ( Type ) -import BasicTypes( Boxity(..), RecFlag(Recursive), - NewOrData(..), StrictnessMark(..) ) -import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) ) -import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignDecl(..) ) +import BasicTypes( Boxity(..), RecFlag(Recursive), NewOrData(..) ) +import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..), + CExportSpec(..)) +import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..), + ForeignDecl(..) ) import FastString( FastString, mkFastString, nilFS ) import Char ( ord, isAscii, isAlphaNum, isAlpha ) import List ( partition ) @@ -57,13 +57,13 @@ mk_con con = case con of -> ConDecl (cName c) noExistentials noContext (InfixCon (mk_arg st1) (mk_arg st2)) loc0 where - mk_arg (IsStrict, ty) = BangType MarkedUserStrict (cvtType ty) - mk_arg (NotStrict, ty) = BangType NotMarkedStrict (cvtType ty) + mk_arg (IsStrict, ty) = BangType HsStrict (cvtType ty) + mk_arg (NotStrict, ty) = BangType HsNoBang (cvtType ty) mk_id_arg (i, IsStrict, ty) - = (vName i, BangType MarkedUserStrict (cvtType ty)) + = (vName i, BangType HsStrict (cvtType ty)) mk_id_arg (i, NotStrict, ty) - = (vName i, BangType NotMarkedStrict (cvtType ty)) + = (vName i, BangType HsNoBang (cvtType ty)) mk_derivs [] = Nothing mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs] @@ -78,29 +78,27 @@ cvt_top (TySynD tc tvs rhs) cvt_top (DataD ctxt tc tvs constrs derivs) = Left $ TyClD (mkTyData DataType (cvt_context ctxt, tconName tc, cvt_tvs tvs) - (DataCons (map mk_con constrs)) + (map mk_con constrs) (mk_derivs derivs) loc0) cvt_top (NewtypeD ctxt tc tvs constr derivs) = Left $ TyClD (mkTyData NewType (cvt_context ctxt, tconName tc, cvt_tvs tvs) - (DataCons [mk_con constr]) + [mk_con constr] (mk_derivs derivs) loc0) cvt_top (ClassD ctxt cl tvs decs) = Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs) noFunDeps sigs - (Just binds) loc0) + binds loc0) where (binds,sigs) = cvtBindsAndSigs decs cvt_top (InstanceD tys ty decs) - = Left $ InstD (InstDecl inst_ty binds sigs Nothing loc0) + = Left $ InstD (InstDecl inst_ty binds sigs loc0) where (binds, sigs) = cvtBindsAndSigs decs - inst_ty = HsForAllTy Nothing - (cvt_context tys) - (HsPredTy (cvt_pred ty)) + inst_ty = mkImplicitHsForAllTy (cvt_context tys) (HsPredTy (cvt_pred ty)) cvt_top (Meta.SigD nm typ) = Left $ Hs.SigD (Sig (vName nm) (cvtType typ) loc0) @@ -120,6 +118,13 @@ cvt_top (ForeignD (ImportF callconv safety from nm typ)) Threadsafe -> PlaySafe True parsed = parse_ccall_impent nm from +cvt_top (ForeignD (ExportF callconv as nm typ)) + = let e = CExport (CExportStatic (mkFastString as) callconv') + in Left $ ForD (ForeignExport (vName nm) (cvtType typ) e False loc0) + where callconv' = case callconv of + CCall -> CCallConv + StdCall -> StdCallConv + parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec) parse_ccall_impent nm s = case lex_ccall_impent s of @@ -220,7 +225,9 @@ cvtd (FunD nm cls) = FunMonoBind (vName nm) False (map cvtclause cls) loc cvtd (Meta.ValD p body ds) = PatMonoBind (cvtp p) (GRHSs (cvtguard body) (cvtdecs ds) void) loc0 -cvtd x = panic "Illegal kind of declaration in where clause" + +cvtd d = cvtPanic "Illegal kind of declaration in where clause" + (text (show (Meta.pprDec d))) cvtclause :: Meta.Clause -> Hs.Match RdrName @@ -237,13 +244,12 @@ cvtdd (FromThenToR x y z) = (FromThenTo (cvt x) (cvt y) (cvt z)) cvtstmts :: [Meta.Stmt] -> [Hs.Stmt RdrName] -cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt -cvtstmts [NoBindS e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt -cvtstmts (NoBindS e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss +cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt +cvtstmts [NoBindS e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt +cvtstmts (NoBindS e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss cvtstmts (Meta.BindS p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss cvtstmts (Meta.LetS ds : ss) = LetStmt (cvtdecs ds) : cvtstmts ss -cvtstmts (Meta.ParS dss : ss) = ParStmt(map cvtstmts dss) : cvtstmts ss - +cvtstmts (Meta.ParS dss : ss) = ParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss cvtm :: Meta.Match -> Hs.Match RdrName cvtm (Meta.Match p body wheres) @@ -284,6 +290,7 @@ cvtp (TildeP p) = LazyPat (cvtp p) cvtp (Meta.AsP s p) = AsPat (vName s) (cvtp p) cvtp Meta.WildP = WildPat void cvtp (RecP c fs) = ConPatIn (cName c) $ Hs.RecCon (map (\(s,p) -> (vName s,cvtp p)) fs) +cvtp (ListP ps) = ListPat (map cvtp ps) void ----------------------------------------------------------- -- Types and type variables @@ -297,7 +304,8 @@ cvt_context tys = map cvt_pred tys cvt_pred :: Meta.Type -> HsPred RdrName cvt_pred ty = case split_ty_app ty of (ConT tc, tys) -> HsClassP (tconName tc) (map cvtType tys) - other -> panic "Malformed predicate" + (VarT tv, tys) -> HsClassP (tName tv) (map cvtType tys) + other -> cvtPanic "Malformed predicate" (text (show (Meta.pprType ty))) cvtType :: Meta.Type -> HsType RdrName cvtType ty = trans (root ty []) @@ -305,7 +313,7 @@ cvtType ty = trans (root ty []) root t zs = (t,zs) trans (TupleT n,args) - | length args == n = HsTupleTy (HsTupCon Boxed n) args + | length args == n = HsTupleTy Boxed args | n == 0 = foldl HsAppTy (HsTyVar (tconName "()")) args | otherwise = foldl HsAppTy (HsTyVar (tconName ("(" ++ replicate (n-1) ',' ++ ")"))) args trans (ArrowT, [x,y]) = HsFunTy x y @@ -314,9 +322,8 @@ cvtType ty = trans (root ty []) trans (VarT nm, args) = foldl HsAppTy (HsTyVar (tName nm)) args trans (ConT tc, args) = foldl HsAppTy (HsTyVar (tconName tc)) args - trans (ForallT tvs cxt ty, []) = mkHsForAllTy (Just (cvt_tvs tvs)) - (cvt_context cxt) - (cvtType ty) + trans (ForallT tvs cxt ty, []) = mkExplicitHsForAllTy + (cvt_tvs tvs) (cvt_context cxt) (cvtType ty) split_ty_app :: Meta.Type -> (Meta.Type, [Meta.Type]) split_ty_app ty = go ty [] @@ -331,6 +338,11 @@ sigP other = False ----------------------------------------------------------- +cvtPanic :: String -> SDoc -> b +cvtPanic herald thing + = pprPanic herald (thing $$ ptext SLIT("When splicing generated code into the program")) + +----------------------------------------------------------- -- some useful things truePat = ConPatIn (cName "True") (PrefixCon [])