X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=84a61ffc268bd064781ec2b98132dd4cc7f2af9d;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hp=88d8954bf17debaa18ecb9c68c2ae5dc77d9c603;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 88d8954..84a61ff 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -1,45 +1,48 @@ % +% (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 -fno-warn-incomplete-patterns #-} +-- 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/Commentary/CodingStyle#Warnings +-- for details -#include "HsVersions.h" +module Convert( convertToHsExpr, convertToPat, 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 ( ModuleName, mkModuleName, mkModule ) -import RdrHsSyn ( mkClassDecl, mkTyData ) +import qualified Class +import RdrName +import qualified Name +import Module +import RdrHsSyn import qualified OccName -import PackageConfig ( PackageId, stringToPackageId ) -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 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 @@ -54,6 +57,13 @@ convertToHsExpr loc e <+> text (show e))) Right res -> Right res +convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName) +convertToPat loc e + = case initCvt loc (cvtPat e) of + Left msg -> Left (msg $$ (ptext SLIT("When converting TH pattern") + <+> text (show e))) + Right res -> Right res + convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName) convertToHsType loc t = initCvt loc (cvtType t) @@ -73,7 +83,7 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a } -- the spliced-in declarations get a location that at least relates to the splice point instance Monad CvtM where - return x = CvtM $ \loc -> Right x + return x = CvtM $ \_ -> Right x (CvtM m) >>= k = CvtM $ \loc -> case m loc of Left err -> Left err Right v -> unCvtM (k v) loc @@ -85,7 +95,7 @@ force :: a -> CvtM a force a = a `seq` return a failWith :: Message -> CvtM a -failWith m = CvtM (\loc -> Left full_msg) +failWith m = CvtM (\_ -> Left full_msg) where full_msg = m $$ ptext SLIT("When splicing generated code into the program") @@ -109,7 +119,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 @@ -125,49 +135,60 @@ 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' } +cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.Name] + -> CvtM (LHsContext RdrName + ,Located RdrName + ,[LHsTyVarBndr RdrName] + ,Maybe [LHsType RdrName]) 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 -- Can't handle GADTs yet --------------------------------------------------- +cvtConstr :: TH.Con -> CvtM (LConDecl RdrName) + 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') @@ -177,17 +198,21 @@ 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 - c -> panic "ForallC: Can't happen" } + ConDecl l _ [] (L _ []) x ResTyH98 _ + -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing + _ -> panic "ForallC: Can't happen" } +cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) 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 :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName) +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 :: [TH.Name] -> CvtM (Maybe [LHsType RdrName]) cvtDerivs [] = return Nothing cvtDerivs cs = do { cs' <- mapM cvt_one cs ; return (Just cs') } @@ -198,6 +223,7 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName)) cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') } +noExistentials :: [LHsTyVarBndr RdrName] noExistentials = [] ------------------------------------------ @@ -210,7 +236,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") @@ -224,10 +250,11 @@ 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.Callconv -> CCallConv +cvt_conv TH.CCall = CCallConv +cvt_conv TH.StdCall = StdCallConv parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec) parse_ccall_impent nm s @@ -279,6 +306,7 @@ cvtDecs [] = return EmptyLocalBinds cvtDecs ds = do { (binds,sigs) <- cvtBindsAndSigs ds ; return (HsValBinds (ValBindsIn binds sigs)) } +cvtBindsAndSigs :: [TH.Dec] -> CvtM (Bag (LHsBind RdrName), [LSig RdrName]) cvtBindsAndSigs ds = do { binds' <- mapM cvtBind binds; sigs' <- mapM cvtSig sigs ; return (listToBag binds', sigs') } @@ -286,8 +314,9 @@ cvtBindsAndSigs ds (sigs, binds) = partition is_sig ds is_sig (TH.SigD _ _) = True - is_sig other = False + is_sig _ = False +cvtSig :: TH.Dec -> CvtM (LSig RdrName) cvtSig (TH.SigD nm ty) = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') } @@ -363,12 +392,15 @@ 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 :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName)) +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' } @@ -380,12 +412,14 @@ cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; retur -- Do notation and statements ------------------------------------- +cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName) cvtHsDo do_or_lc stmts = do { stmts' <- cvtStmts stmts ; let body = case last stmts' of L _ (ExprStmt body _ _) -> body ; return $ HsDo do_or_lc (init stmts') body void } +cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName] cvtStmts = mapM cvtStmt cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName) @@ -409,14 +443,15 @@ cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; retur cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs - ; g' <- returnL $ mkBindStmt truePat ge' + ; g' <- returnL $ mkExprStmt ge' ; returnL $ GRHS [g'] rhs' } cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs ; returnL $ GRHS gs' 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 (IntegerL i) = do { force i; return $ mkHsIntegral i placeHolderType} +cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r placeHolderType} +cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' placeHolderType } -- An Integer is like an an (overloaded) '3' in a Haskell source program -- Similarly 3.5 for fractionals @@ -450,11 +485,14 @@ 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 :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) +cvtPatFld (s,p) + = do { s' <- vNameL s; p' <- cvtPat p + ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) } ----------------------------------------------------------- -- Types and type variables @@ -462,6 +500,7 @@ cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (s',p') } cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName] cvtTvs tvs = mapM cvt_tv tvs +cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName) cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' } cvtContext :: Cxt -> CvtM (LHsContext RdrName) @@ -473,7 +512,7 @@ cvtPred ty ; case head of ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' } VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' } - other -> failWith (ptext SLIT("Malformed predicate") <+> text (TH.pprint ty)) } + _ -> failWith (ptext SLIT("Malformed predicate") <+> text (TH.pprint ty)) } cvtType :: TH.Type -> CvtM (LHsType RdrName) cvtType ty = do { (head, tys') <- split_ty_app ty @@ -490,7 +529,7 @@ cvtType ty = do { (head, tys') <- split_ty_app ty ; cxt' <- cvtContext cxt ; ty' <- cvtType ty ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' } - otherwise -> failWith (ptext SLIT("Malformed type") <+> text (show ty)) + _ -> failWith (ptext SLIT("Malformed type") <+> text (show ty)) } where mk_apps head [] = returnL head @@ -508,13 +547,11 @@ split_ty_app ty = go ty [] ----------------------------------------------------------- -- some useful things -truePat = nlConPat (getRdrName trueDataCon) [] - overloadedLit :: Lit -> Bool -- True for literals that Haskell treats as overloaded -overloadedLit (IntegerL l) = True -overloadedLit (RationalL l) = True -overloadedLit l = False +overloadedLit (IntegerL _) = True +overloadedLit (RationalL _) = True +overloadedLit _ = False void :: Type.Type void = placeHolderType @@ -570,8 +607,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 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)) noSrcLoc) +thRdrName _ 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 @@ -587,11 +624,11 @@ isBuiltInOcc ctxt_ns occ "[]" -> Just (Name.getName nilDataCon) "()" -> Just (tup_name 0) '(' : ',' : rest -> go_tuple 2 rest - other -> Nothing + _ -> Nothing where go_tuple n ")" = Just (tup_name n) go_tuple n (',' : rest) = go_tuple (n+1) rest - go_tuple n other = Nothing + go_tuple _ _ = Nothing tup_name n | OccName.isTcClsName ctxt_ns = Name.getName (tupleTyCon Boxed n)