X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=42aa001f7c9773192788854c45729f2ef57e7c3f;hp=76e51dfb835306422bd39b6dec96c832797e25b7;hb=6821c8a47c0fc61a2d989d368f926cc0ded776e9;hpb=90dc9026b091be5cca5da4c6cbd3713ecc493361 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 76e51df..42aa001 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -6,11 +6,16 @@ This module converts Template Haskell syntax into HsSyn \begin{code} -module Convert( convertToHsExpr, convertToHsDecls, +{-# 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 + +module Convert( convertToHsExpr, convertToPat, convertToHsDecls, convertToHsType, thRdrName ) where -#include "HsVersions.h" - import HsSyn as Hs import qualified Class import RdrName @@ -18,7 +23,6 @@ import qualified Name import Module import RdrHsSyn import qualified OccName -import PackageConfig import OccName import SrcLoc import Type @@ -47,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) @@ -70,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 @@ -82,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)) @@ -140,6 +151,11 @@ cvtTop (InstanceD tys ty decs) 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 @@ -151,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 [] @@ -180,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') } @@ -199,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 = [] ------------------------------------------ @@ -214,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 @@ -227,6 +250,7 @@ cvtForD (ExportF callconv as nm ty) ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv)) ; return $ ForeignExport nm' ty' e } +cvt_conv :: TH.Callconv -> CCallConv cvt_conv TH.CCall = CCallConv cvt_conv TH.StdCall = StdCallConv @@ -280,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') } @@ -287,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') } @@ -313,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) @@ -364,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' } @@ -381,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) @@ -410,20 +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 (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' } +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 } @@ -452,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 @@ -464,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) @@ -475,7 +511,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 @@ -492,7 +528,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 @@ -510,13 +546,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 @@ -558,8 +592,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 @@ -572,8 +606,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 @@ -589,11 +623,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)