-----------------------------------------------------------------------------
+--
+-- (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
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
-------------------------------------------------------
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']
= 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' }
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
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) }
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
projects / ghc-hetmet.git / blobdiff