X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMeta.hs;h=fcbcc7834736ad8b8e5d236841c1a885d3cdf179;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=8328783a889222c5019c3bc0a5be7894044f42a6;hpb=b5e9d715525281915846fa02d5d0b1402887e4de;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 8328783..fcbcc78 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -30,16 +30,16 @@ import qualified Language.Haskell.TH as TH import HsSyn import Class (FunDep) import PrelNames ( rationalTyConName, integerTyConName, negateName ) -import OccName ( isDataOcc, isTvOcc, occNameUserString ) +import OccName ( isDataOcc, isTvOcc, occNameString ) -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName -- we do this by removing varName from the import of OccName above, making -- a qualified instance of OccName and using OccNameAlias.varName where varName -- ws previously used in this file. import qualified OccName -import Module ( Module, mkModule, moduleUserString ) +import Module ( Module, mkModule, moduleString ) import Id ( Id, mkLocalId ) -import OccName ( mkOccFS ) +import OccName ( mkOccNameFS ) import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule, isExternalName, getSrcLoc ) import NameEnv @@ -54,10 +54,9 @@ import Maybe ( catMaybes ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) ) import BasicTypes ( isBoxed ) import Outputable -import Bag ( bagToList ) +import Bag ( bagToList, unionManyBags ) import FastString ( unpackFS ) -import ForeignCall ( Safety(..), ForeignCall(..), CCallConv(..), - CCallTarget(..) ) +import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) ) import Monad ( zipWithM ) import List ( sortBy ) @@ -112,12 +111,12 @@ repTopDs group decls <- addBinds ss (do { - val_ds <- mapM rep_bind_group (hs_valds group) ; + val_ds <- rep_val_binds (hs_valds group) ; tycl_ds <- mapM repTyClD (hs_tyclds group) ; inst_ds <- mapM repInstD' (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed - return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ; + return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -132,7 +131,7 @@ repTopDs group groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) -- Collect the binders of a Group - = collectGroupBinders val_decls ++ + = collectHsValBinders val_decls ++ [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++ [n | L _ (ForeignImport n _ _ _) <- foreign_decls] @@ -205,16 +204,16 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, cxt1 <- repLContext cxt ; sigs1 <- rep_sigs sigs ; binds1 <- rep_binds meth_binds ; - fds1 <- repLFunDeps fds; + fds1 <- repLFunDeps fds; decls1 <- coreList decQTyConName (sigs1 ++ binds1) ; bndrs1 <- coreList nameTyConName bndrs ; repClass cxt1 cls1 bndrs1 fds1 decls1 } ; return $ Just (loc, dec) } -- Un-handled cases -repTyClD (L loc d) = do { dsWarn (loc, hang ds_msg 4 (ppr d)) ; - return Nothing - } +repTyClD (L loc d) = putSrcSpanDs loc $ + do { dsWarn (hang ds_msg 4 (ppr d)) + ; return Nothing } -- represent fundeps -- @@ -286,23 +285,22 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") ------------------------------------------------------- repC :: LConDecl Name -> DsM (Core TH.ConQ) -repC (L loc (ConDecl con [] (L _ []) details)) +repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98)) = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences] repConstr con1 details } -repC (L loc (ConDecl con tvs (L cloc ctxt) details)) +repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98)) = do { addTyVarBinds tvs $ \bndrs -> do { - c' <- repC (L loc (ConDecl con [] (L cloc []) details)); + c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98)); ctxt' <- repContext ctxt; bndrs' <- coreList nameTyConName bndrs; rep2 forallCName [unC bndrs', unC ctxt', unC c'] } } -repC (L loc con_decl) - = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl)) +repC (L loc con_decl) -- GADTs + = putSrcSpanDs loc $ + do { dsWarn (hang ds_msg 4 (ppr con_decl)) ; return (panic "DsMeta:repC") } --- gaw 2004 FIX! Need a case for GadtDecl - repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) repBangTy ty= do MkC s <- rep2 str [] @@ -345,8 +343,8 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc -rep_sig other = return [] +rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc +rep_sig other = return [] rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; @@ -514,13 +512,13 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs -- FIXME: I haven't got the types here right yet repE (HsDo DoExpr sts body ty) = do { (ss,zs) <- repLSts sts; - body' <- repLE body; + body' <- addBinds ss $ repLE body; ret <- repNoBindSt body'; e <- repDoE (nonEmptyCoreList (zs ++ [ret])); wrapGenSyns ss e } repE (HsDo ListComp sts body ty) = do { (ss,zs) <- repLSts sts; - body' <- repLE body; + body' <- addBinds ss $ repLE body; ret <- repNoBindSt body'; e <- repComp (nonEmptyCoreList (zs ++ [ret])); wrapGenSyns ss e } @@ -610,7 +608,7 @@ repGuards other return ([], x) } process (L _ (GRHS ss rhs)) = do (gs, ss') <- repLSts ss - rhs' <- repLE rhs + rhs' <- addBinds gs $ repLE rhs g <- repPatGE (nonEmptyCoreList ss') rhs' return (gs, g) @@ -669,7 +667,7 @@ repSts (ExprStmt e _ _ : ss) = ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } -repSts [] = panic "repSts ran out of statements" +repSts [] = return ([],[]) repSts other = panic "Exotic Stmt in meta brackets" @@ -677,38 +675,39 @@ repSts other = panic "Exotic Stmt in meta brackets" -- Bindings ----------------------------------------------------------- -repBinds :: [HsBindGroup Name] -> DsM ([GenSymBind], Core [TH.DecQ]) -repBinds decs - = do { let { bndrs = map unLoc (collectGroupBinders decs) } +repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) +repBinds EmptyLocalBinds + = do { core_list <- coreList decQTyConName [] + ; return ([], core_list) } + +repBinds (HsIPBinds _) + = panic "DsMeta:repBinds: can't do implicit parameters" + +repBinds (HsValBinds decs) + = do { let { bndrs = map unLoc (collectHsValBinders decs) } -- No need to worrry about detailed scopes within -- the binding group, because we are talking Names -- here, so we can safely treat it as a mutually -- recursive group ; ss <- mkGenSyms bndrs - ; core <- addBinds ss (rep_bind_groups decs) - ; core_list <- coreList decQTyConName core + ; prs <- addBinds ss (rep_val_binds decs) + ; core_list <- coreList decQTyConName + (de_loc (sort_by_loc prs)) ; return (ss, core_list) } -rep_bind_groups :: [HsBindGroup Name] -> DsM [Core TH.DecQ] +rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are alrady in the meta-env -rep_bind_groups binds = do - locs_cores_s <- mapM rep_bind_group binds - return $ de_loc $ sort_by_loc (concat locs_cores_s) - -rep_bind_group :: HsBindGroup Name -> DsM [(SrcSpan, Core TH.DecQ)] --- Assumes: all the binders of the binding are alrady in the meta-env -rep_bind_group (HsBindGroup bs sigs _) - = do { core1 <- mapM rep_bind (bagToList bs) +rep_val_binds (ValBindsOut binds sigs) + = do { core1 <- rep_binds' (unionManyBags (map snd binds)) ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_bind_group (HsIPBinds _) - = panic "DsMeta:repBinds: can't do implicit parameters" rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] --- Assumes: all the binders of the binding are alrady in the meta-env -rep_binds binds = do - locs_cores <- mapM rep_bind (bagToList binds) - return $ de_loc $ sort_by_loc locs_cores +rep_binds binds = do { binds_w_locs <- rep_binds' binds + ; return (de_loc (sort_by_loc binds_w_locs)) } + +rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_binds' binds = mapM rep_bind (bagToList binds) rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are alrady in the meta-env @@ -716,7 +715,7 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _))) +rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _) _)) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -725,13 +724,13 @@ rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards whe ; ans' <- wrapGenSyns ss ans ; return (loc, ans') } -rep_bind (L loc (FunBind fn infx (MatchGroup ms _))) +rep_bind (L loc (FunBind fn infx (MatchGroup ms _) _)) = do { ms1 <- mapM repClauseTup ms ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2)) +rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2 _)) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) @@ -773,7 +772,7 @@ rep_bind (L loc (VarBind v e)) -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch Name -> DsM (Core TH.ExpQ) -repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] []))) +repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( @@ -876,7 +875,7 @@ lookupBinder n = do { mb_val <- dsLookupMetaEnv n; case mb_val of Just (Bound x) -> return (coreVar x) - other -> pprPanic "Failed binder lookup:" (ppr n) } + other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) } -- Look up a name that is either locally bound or a global name -- @@ -912,7 +911,7 @@ globalVar name ; MkC uni <- coreIntLit (getKey (getUnique name)) ; rep2 mkNameLName [occ,uni] } where - name_mod = moduleUserString (nameModule name) + name_mod = moduleString (nameModule name) name_occ = nameOccName name mk_varg | OccName.isDataOcc name_occ = mkNameG_dName | OccName.isVarOcc name_occ = mkNameG_vName @@ -964,7 +963,7 @@ wrapNongenSyms binds (MkC body) ; return (NonRec id var) } occNameLit :: Name -> DsM (Core String) -occNameLit n = coreStringLit (occNameUserString (nameOccName n)) +occNameLit n = coreStringLit (occNameString (nameOccName n)) -- %********************************************************************* @@ -1391,7 +1390,7 @@ thSyn = mkModule "Language.Haskell.TH.Syntax" thLib = mkModule "Language.Haskell.TH.Lib" mk_known_key_name mod space str uniq - = mkExternalName uniq mod (mkOccFS space str) + = mkExternalName uniq mod (mkOccNameFS space str) Nothing noSrcLoc libFun = mk_known_key_name thLib OccName.varName