X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=18f40e3874768c0ad6dba372621b88033b0b5232;hp=77e9e082243518701ea98018676ceb1dd0a55127;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=7f546581e86c816ece1f7c877560ffa1cf385165 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 77e9e08..18f40e3 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -1,44 +1,49 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % This module converts Template Haskell syntax into HsSyn - \begin{code} -module Convert( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) where +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings +-- for details -#include "HsVersions.h" +module Convert( convertToHsExpr, convertToHsDecls, + convertToHsType, thRdrName ) where -import Language.Haskell.TH as TH hiding (sigP) -import Language.Haskell.TH.Syntax as TH +#include "HsVersions.h" import HsSyn as Hs -import qualified Class (FunDep) -import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName ) -import qualified Name ( Name, mkInternalName, getName ) -import Module ( Module, mkModule ) -import RdrHsSyn ( mkClassDecl, mkTyData ) +import qualified Class +import RdrName +import qualified Name +import Module +import RdrHsSyn import qualified OccName -import OccName ( startsVarId, startsVarSym, startsConId, startsConSym, - pprNameSpace ) -import SrcLoc ( Located(..), SrcSpan ) -import Type ( Type ) -import TysWiredIn ( unitTyCon, tupleTyCon, tupleCon, trueDataCon, nilDataCon, consDataCon ) -import BasicTypes( Boxity(..) ) -import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..), - CExportSpec(..)) -import Char ( isAscii, isAlphaNum, isAlpha ) -import List ( partition ) -import Unique ( Unique, mkUniqueGrimily ) -import ErrUtils ( Message ) -import GLAEXTS ( Int(..), Int# ) -import SrcLoc ( noSrcLoc ) -import Bag ( listToBag ) +import PackageConfig +import OccName +import SrcLoc +import Type +import TysWiredIn +import BasicTypes +import ForeignCall +import Char +import List +import Unique +import ErrUtils +import Bag import FastString import Outputable +import Language.Haskell.TH as TH hiding (sigP) +import Language.Haskell.TH.Syntax as TH +import GHC.Exts ------------------------------------------------------------------- -- The external interface @@ -108,7 +113,7 @@ cvtTop (TySynD tc tvs rhs) = do { tc' <- tconNameL tc ; tvs' <- cvtTvs tvs ; rhs' <- cvtType rhs - ; returnL $ TyClD (TySynonym tc' tvs' rhs') } + ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') } cvtTop (DataD ctxt tc tvs constrs derivs) = do { stuff <- cvt_tycl_hdr ctxt tc tvs @@ -124,17 +129,21 @@ cvtTop (NewtypeD ctxt tc tvs constr derivs) ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') } cvtTop (ClassD ctxt cl tvs fds decs) - = do { stuff <- cvt_tycl_hdr ctxt cl tvs + = do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds ; (binds', sigs') <- cvtBindsAndSigs decs - ; returnL $ TyClD $ mkClassDecl stuff fds' sigs' binds' } + ; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] [] + -- no ATs or docs in TH ^^ ^^ + } cvtTop (InstanceD tys ty decs) = do { (binds', sigs') <- cvtBindsAndSigs decs ; ctxt' <- cvtContext tys ; L loc pred' <- cvtPred ty ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred')) - ; returnL $ InstD (InstDecl inst_ty' binds' sigs') } + ; returnL $ InstD (InstDecl inst_ty' binds' sigs' []) + -- ^^no ATs in TH + } cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' } @@ -142,7 +151,7 @@ cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs') } + ; return (cxt', tc', tvs', Nothing) } --------------------------------------------------- -- Data types @@ -153,20 +162,20 @@ cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys - ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 } + ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 } + ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing } cvtConstr (InfixC st1 c st2) = do { c' <- cNameL c ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 } + ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing } cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con')) = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con') @@ -176,16 +185,17 @@ cvtConstr (ForallC tvs ctxt con) ; tvs' <- cvtTvs tvs ; ctxt' <- cvtContext ctxt ; case con' of - ConDecl l _ [] (L _ []) x ResTyH98 - -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 + ConDecl l _ [] (L _ []) x ResTyH98 _ + -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing c -> panic "ForallC: Can't happen" } cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' } cvt_arg (NotStrict, ty) = cvtType ty -cvt_id_arg (i, str, ty) = do { i' <- vNameL i - ; ty' <- cvt_arg (str,ty) - ; return (i', ty') } +cvt_id_arg (i, str, ty) + = do { i' <- vNameL i + ; ty' <- cvt_arg (str,ty) + ; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) } cvtDerivs [] = return Nothing cvtDerivs cs = do { cs' <- mapM cvt_one cs @@ -209,7 +219,7 @@ cvtForD (ImportF callconv safety from nm ty) = do { nm' <- vNameL nm ; ty' <- cvtType ty ; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis - ; return $ ForeignImport nm' ty' i False } + ; return $ ForeignImport nm' ty' i } | otherwise = failWith $ text (show from)<+> ptext SLIT("is not a valid ccall impent") @@ -223,10 +233,10 @@ cvtForD (ExportF callconv as nm ty) = do { nm' <- vNameL nm ; ty' <- cvtType ty ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv)) - ; return $ ForeignExport nm' ty' e False } + ; return $ ForeignExport nm' ty' e } -cvt_conv CCall = CCallConv -cvt_conv StdCall = StdCallConv +cvt_conv TH.CCall = CCallConv +cvt_conv TH.StdCall = StdCallConv parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec) parse_ccall_impent nm s @@ -362,12 +372,14 @@ cvtl e = wrapL (cvt e) ; return $ ExprWithTySig e' t' } cvt (RecConE c flds) = do { c' <- cNameL c ; flds' <- mapM cvtFld flds - ; return $ RecordCon c' noPostTcExpr flds' } + ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)} cvt (RecUpdE e flds) = do { e' <- cvtl e ; flds' <- mapM cvtFld flds - ; return $ RecordUpd e' flds' placeHolderType placeHolderType } + ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] } -cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (v',e') } +cvtFld (v,e) + = do { v' <- vNameL v; e' <- cvtl e + ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) } cvtDD :: Range -> CvtM (ArithSeqInfo RdrName) cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } @@ -416,6 +428,7 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i } cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r } +cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' } -- An Integer is like an an (overloaded) '3' in a Haskell source program -- Similarly 3.5 for fractionals @@ -449,11 +462,13 @@ cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } cvtp TH.WildP = return $ WildPat void cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' $ Hs.RecCon fs' } + ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } -cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (s',p') } +cvtPatFld (s,p) + = do { s' <- vNameL s; p' <- cvtPat p + ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) } ----------------------------------------------------------- -- Types and type variables @@ -569,8 +584,8 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- which will give confusing error messages later -- -- The strict applications ensure that any buried exceptions get forced -thRdrName ctxt_ns occ (TH.NameG th_ns mod) = (mkOrig $! (mk_mod mod)) $! (mk_occ (mk_ghc_ns th_ns) occ) -thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcLoc) +thRdrName ctxt_ns occ (TH.NameG th_ns pkg mod) = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) +thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan) thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ) thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq) thRdrName ctxt_ns occ TH.NameS @@ -617,8 +632,11 @@ mk_ghc_ns TH.DataName = OccName.dataName mk_ghc_ns TH.TcClsName = OccName.tcClsName mk_ghc_ns TH.VarName = OccName.varName -mk_mod :: TH.ModName -> Module -mk_mod mod = mkModule (TH.modString mod) +mk_mod :: TH.ModName -> ModuleName +mk_mod mod = mkModuleName (TH.modString mod) + +mk_pkg :: TH.ModName -> PackageId +mk_pkg pkg = stringToPackageId (TH.pkgString pkg) mk_uniq :: Int# -> Unique mk_uniq u = mkUniqueGrimily (I# u)