X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=5a5bb1b1a9d8b0271ae3bdff53c0f38a7a5886f1;hp=dff6a1405b9c3cd3c6a7c6b468532bf0ea3634b6;hb=92eeda1e1d846a082a60caab1b75593d7cc668ed;hpb=190f24892156953d73b55401d0467a6f1a88ce5d diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index dff6a14..5a5bb1b 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -1,45 +1,46 @@ % +% (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" - -import Language.Haskell.TH as TH hiding (sigP) -import Language.Haskell.TH.Syntax as TH +module Convert( convertToHsExpr, convertToPat, convertToHsDecls, + convertToHsType, thRdrName ) where 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 @@ -50,10 +51,17 @@ convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds) convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName) convertToHsExpr loc e = case initCvt loc (cvtl e) of - Left msg -> Left (msg $$ (ptext SLIT("When converting TH expression") + Left msg -> Left (msg $$ (ptext (sLit "When converting TH expression") <+> 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 +81,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,9 +93,9 @@ 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") + full_msg = m $$ ptext (sLit "When splicing generated code into the program") returnL :: a -> CvtM (Located a) returnL x = CvtM (\loc -> Right (L loc x)) @@ -138,11 +146,16 @@ cvtTop (InstanceD tys ty decs) ; L loc pred' <- cvtPred ty ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred')) ; returnL $ InstD (InstDecl inst_ty' binds' sigs' []) - -- ^^no ATs in TH + -- 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 @@ -154,6 +167,8 @@ cvt_tycl_hdr cxt tc tvs -- Can't handle GADTs yet --------------------------------------------------- +cvtConstr :: TH.Con -> CvtM (LConDecl RdrName) + cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; cxt' <- returnL [] @@ -183,15 +198,19 @@ cvtConstr (ForallC tvs ctxt con) ; case con' of ConDecl l _ [] (L _ []) x ResTyH98 _ -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing - c -> panic "ForallC: Can't happen" } + _ -> 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 (mkRecField 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') } @@ -202,6 +221,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 = [] ------------------------------------------ @@ -217,7 +237,7 @@ cvtForD (ImportF callconv safety from nm ty) ; return $ ForeignImport nm' ty' i } | otherwise - = failWith $ text (show from)<+> ptext SLIT("is not a valid ccall impent") + = failWith $ text (show from)<+> ptext (sLit "is not a valid ccall impent") where safety' = case safety of Unsafe -> PlayRisky @@ -230,8 +250,9 @@ cvtForD (ExportF callconv as nm ty) ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv)) ; 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 @@ -283,6 +304,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') } @@ -290,8 +312,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') } @@ -316,7 +339,7 @@ cvtBind (TH.ValD p body ds) pat_rhs_ty = void, bind_fvs = placeHolderNames } } cvtBind d - = failWith (sep [ptext SLIT("Illegal kind of declaration in where clause"), + = failWith (sep [ptext (sLit "Illegal kind of declaration in where clause"), nest 2 (text (TH.pprint d))]) cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName) @@ -343,7 +366,7 @@ cvtl e = wrapL (cvt e) cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' } cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } - cvt (TupE [e]) = cvt e + cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed } cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z ; return $ HsIf x' y' z' } @@ -367,12 +390,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' } @@ -384,12 +410,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) @@ -413,19 +441,21 @@ 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 cvtLit :: Lit -> CvtM HsLit cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i } +cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w } cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f } cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f } cvtLit (CharL c) = do { force c; return $ HsChar c } @@ -454,11 +484,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 (mkRecField 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 @@ -466,6 +499,7 @@ cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (mkRecField 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) @@ -477,13 +511,16 @@ 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 - ; case head of - TupleT n | length tys' == n -> returnL (HsTupleTy Boxed tys') - | n == 0 -> mk_apps (HsTyVar (getRdrName unitTyCon)) tys' +cvtType ty = do { (head_ty, tys') <- split_ty_app ty + ; case head_ty of + TupleT n | length tys' == n -- Saturated + -> if n==1 then return (head tys') -- Singleton tuples treated + -- like nothing (ie just parens) + else returnL (HsTupleTy Boxed tys') + | n == 1 -> failWith (ptext (sLit "Illegal 1-tuple type constructor")) | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') ListT | [x'] <- tys' -> returnL (HsListTy x') @@ -494,11 +531,12 @@ 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 - mk_apps head (ty:tys) = do { head' <- returnL head; mk_apps (HsAppTy head' ty) tys } + mk_apps head_ty [] = returnL head_ty + mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty + ; mk_apps (HsAppTy head_ty' ty) tys } split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName]) split_ty_app ty = go ty [] @@ -512,13 +550,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 @@ -560,8 +596,8 @@ okOcc ns str@(c:_) badOcc :: OccName.NameSpace -> String -> SDoc badOcc ctxt_ns occ - = ptext SLIT("Illegal") <+> pprNameSpace ctxt_ns - <+> ptext SLIT("name:") <+> quotes (text occ) + = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns + <+> ptext (sLit "name:") <+> quotes (text occ) thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- This turns a Name into a RdrName @@ -574,8 +610,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 @@ -591,11 +627,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)