X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=f24641213d3967fbd7b670779ef659fa10ac8150;hp=d85782b2001c1c3a36bc269daf814338748c98f7;hb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;hpb=7a59afcebe45ea87c42006873f77eb4600d7316f diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index d85782b..f246412 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- -- The purpose of this module is to transform an HsExpr into a CoreExpr which -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the -- input HsExpr. We do this in the DsM monad, which supplies access to @@ -21,47 +24,45 @@ module DsMeta( dsBracket, import {-# SOURCE #-} DsExpr ( dsExpr ) -import MatchLit ( dsLit ) -import DsUtils ( mkListExpr, mkStringExpr, mkIntExpr ) +import MatchLit +import DsUtils import DsMonad import qualified Language.Haskell.TH as TH import HsSyn -import Class (FunDep) -import PrelNames ( rationalTyConName, integerTyConName, negateName ) -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 Class +import PrelNames +import OccName +-- 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, moduleNameString, moduleName, - modulePackageId, mkModuleNameFS ) -import Id ( Id, mkLocalId ) -import OccName ( mkOccNameFS ) -import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule, - isExternalName, getSrcLoc ) +import Module +import Id +import OccName +import Name import NameEnv -import Type ( Type, mkTyConApp ) -import TcType ( tcTyConAppArgs ) -import TyCon ( tyConName ) -import TysWiredIn ( parrTyCon ) +import Type +import TcType +import TyCon +import TysWiredIn import CoreSyn -import CoreUtils ( exprType ) -import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan ) -import PackageConfig ( thPackageId, packageIdString ) -import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) ) -import BasicTypes ( isBoxed ) +import CoreUtils +import SrcLoc +import PackageConfig +import Unique +import BasicTypes import Outputable -import Bag ( bagToList, unionManyBags ) -import FastString ( unpackFS ) -import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) ) +import Bag +import FastString +import ForeignCall -import Maybe ( catMaybes ) -import Monad ( zipWithM ) -import List ( sortBy ) +import Data.Maybe +import Control.Monad +import Data.List ----------------------------------------------------------------------------- dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr @@ -231,7 +232,7 @@ repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs ys_list <- coreList nameTyConName ys' repFunDep xs_list ys_list -repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now +repInstD' (L loc (InstDecl ty binds _ _)) -- Ignore user pragmas for now = do { i <- addTyVarBinds tvs $ \tv_bndrs -> -- We must bring the type variables into scope, so their occurrences -- don't fail, even though the binders don't appear in the resulting @@ -289,12 +290,12 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") ------------------------------------------------------- repC :: LConDecl Name -> DsM (Core TH.ConQ) -repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98)) +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 expl tvs (L cloc ctxt) details ResTyH98)) +repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc)) = do { addTyVarBinds tvs $ \bndrs -> do { - c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98)); + c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc)); ctxt' <- repContext ctxt; bndrs' <- coreList nameTyConName bndrs; rep2 forallCName [unC bndrs', unC ctxt', unC c'] @@ -815,8 +816,8 @@ repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } - RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs) - ; ps <- sequence $ map repLP (map snd pairs) + RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs) + ; ps <- sequence $ map repLP (map hsRecFieldArg pairs) ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps ; fps' <- coreList fieldPatQTyConName fps ; repPrec con_str fps' } @@ -1192,8 +1193,8 @@ repConstr con (PrefixCon ps) arg_tys1 <- coreList strictTypeQTyConName arg_tys rep2 normalCName [unC con, unC arg_tys1] repConstr con (RecCon ips) - = do arg_vs <- mapM lookupLOcc (map fst ips) - arg_tys <- mapM repBangTy (map snd ips) + = do arg_vs <- mapM lookupLOcc (map hsRecFieldId ips) + arg_tys <- mapM repBangTy (map hsRecFieldArg ips) arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y]) arg_vs arg_tys arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys @@ -1306,6 +1307,9 @@ nonEmptyCoreList :: [Core a] -> Core [a] nonEmptyCoreList [] = panic "coreList: empty argument" nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) +corePair :: (Core a, Core b) -> Core (a,b) +corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y]) + coreStringLit :: String -> DsM (Core String) coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } @@ -1408,14 +1412,10 @@ thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib") mkTHModule m = mkModule thPackageId (mkModuleNameFS m) -mk_known_key_name mod space str uniq - = mkExternalName uniq mod (mkOccNameFS space str) - Nothing noSrcLoc - -libFun = mk_known_key_name thLib OccName.varName -libTc = mk_known_key_name thLib OccName.tcName -thFun = mk_known_key_name thSyn OccName.varName -thTc = mk_known_key_name thSyn OccName.tcName +libFun = mk_known_key_name OccName.varName thLib +libTc = mk_known_key_name OccName.tcName thLib +thFun = mk_known_key_name OccName.varName thSyn +thTc = mk_known_key_name OccName.tcName thSyn -------------------- TH.Syntax ----------------------- qTyConName = thTc FSLIT("Q") qTyConKey