1 {-# LANGUAGE ViewPatterns #-}
5 import qualified Unsafe.Coerce
10 import qualified HscMain
11 import qualified HscTypes
12 import qualified DynFlags
13 import qualified FastString
14 import qualified StringBuffer
15 import qualified MonadUtils
16 import Outputable ( showSDoc, ppr )
17 import qualified Outputable
18 -- Lexer & Parser, i.e. up to HsExpr
19 import qualified Lexer
20 import qualified Parser
21 -- HsExpr representation, renaming, typechecking and desugaring
22 -- (i.e., everything up to Core).
23 import qualified HsSyn
24 import qualified HsExpr
25 import qualified HsTypes
26 import qualified HsBinds
27 import qualified TcRnMonad
28 import qualified TcRnTypes
29 import qualified RnExpr
30 import qualified RnEnv
31 import qualified TcExpr
32 import qualified TcEnv
33 import qualified TcSimplify
34 import qualified Desugar
35 import qualified InstEnv
36 import qualified FamInstEnv
37 import qualified PrelNames
38 import qualified Module
39 import qualified OccName
40 import qualified RdrName
42 import qualified TysWiredIn
43 import qualified SrcLoc
44 import qualified LoadIface
45 import qualified BasicTypes
47 -- Core representation and handling
48 import qualified CoreSyn
51 import qualified TyCon
58 -- | Translate a HsExpr to a Core expression. This does renaming, type
59 -- checking, simplification of class instances and desugaring. The result is
60 -- a let expression that holds the given expression and a number of binds that
61 -- are needed for any type classes used to work. For example, the HsExpr:
62 -- \x = x == (1 :: Int)
63 -- will result in the CoreExpr
66 -- (==) = Prelude.(==) Int $dInt
70 [Module.ModuleName] -- ^ The modules that need to be imported before translating
72 -> HsSyn.HsExpr RdrName.RdrName -- ^ The expression to translate to Core.
73 -> GHC.Ghc CoreSyn.CoreExpr -- ^ The resulting core expression.
74 toCore modules expr = do
76 let icontext = HscTypes.hsc_IC env
78 (binds, tc_expr) <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
79 -- Translage the TcRn (typecheck-rename) monad into an IO monad
80 TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
81 (tc_expr, insts) <- TcRnMonad.getLIE $ do
82 mapM importModule modules
83 -- Rename the expression, resulting in a HsExpr Name
84 (rn_expr, freevars) <- RnExpr.rnExpr expr
85 -- Typecheck the expression, resulting in a HsExpr Id and a list of
87 (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
89 -- Translate the instances into bindings
90 --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
91 binds <- TcSimplify.tcSimplifyTop insts
92 return (binds, tc_expr)
94 -- Create a let expression with the extra binds (for polymorphism etc.) and
95 -- the resulting expression.
96 let letexpr = SrcLoc.noLoc $ HsExpr.HsLet
97 (HsBinds.HsValBinds $ HsBinds.ValBindsOut [(BasicTypes.NonRecursive, binds)] [])
99 -- Desugar the expression, resulting in core.
100 let rdr_env = HscTypes.ic_rn_gbl_env icontext
101 desugar_expr <- HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr
105 -- | Create an Id from a RdrName. Might not work for DataCons...
106 mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
108 env <- GHC.getSession
109 id <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
110 -- Translage the TcRn (typecheck-rename) monad in an IO monad
111 TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $
112 -- Automatically import all available modules, so fully qualified names
114 TcRnMonad.setOptM DynFlags.Opt_ImplicitImportQualified $ do
115 -- Lookup a Name for the RdrName. This finds the package (version) in
116 -- which the name resides.
117 name <- RnEnv.lookupGlobalOccRn rdr_name
118 -- Lookup an Id for the Name. This finds out the the type of the thing
119 -- we're looking for.
121 -- Note that tcLookupId doesn't seem to work for DataCons. See source for
122 -- tcLookupId to find out.
123 TcEnv.tcLookupId name
126 -- | Translate a core Type to an HsType. Far from complete so far.
127 coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
128 -- Translate TyConApps
129 coreToHsType ty = case Type.splitTyConApp_maybe ty of
131 foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
133 tycon_name = TyCon.tyConName tycon
134 mod_name = Module.moduleName $ Name.nameModule tycon_name
135 occ_name = Name.nameOccName tycon_name
136 tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
137 tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
138 Nothing -> error $ "HsTools.coreToHsType Cannot translate non-tycon type"
140 -- | Evaluate a CoreExpr and return its value. For this to work, the caller
141 -- should already know the result type for sure, since the result value is
142 -- unsafely coerced into this type.
143 execCore :: CoreSyn.CoreExpr -> GHC.Ghc a
145 -- Setup session flags (yeah, this seems like a noop, but
146 -- setSessionDynFlags really does some extra work...)
147 dflags <- GHC.getSessionDynFlags
148 GHC.setSessionDynFlags dflags
149 -- Compile the expressions. This runs in the IO monad, but really wants
150 -- to run an IO-monad-inside-a-GHC-monad for some reason. I don't really
151 -- understand what it means, but it works.
152 env <- GHC.getSession
153 let srcspan = SrcLoc.mkGeneralSrcSpan (FastString.fsLit "XXX")
154 hval <- MonadUtils.liftIO $ HscMain.compileExpr env srcspan expr
155 let res = Unsafe.Coerce.unsafeCoerce hval :: Int
156 return $ Unsafe.Coerce.unsafeCoerce hval
158 -- These functions build (parts of) a LHSExpr RdrName.
160 -- | A reference to the Prelude.undefined function.
161 hsUndef :: HsExpr.LHsExpr RdrName.RdrName
162 hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
164 -- | A typed reference to the Prelude.undefined function.
165 hsTypedUndef :: HsTypes.LHsType RdrName.RdrName -> HsExpr.LHsExpr RdrName.RdrName
166 hsTypedUndef ty = SrcLoc.noLoc $ HsExpr.ExprWithTySig hsUndef ty
168 -- | Create a qualified RdrName from a module name and a variable name
169 mkRdrName :: String -> String -> RdrName.RdrName
171 RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
173 -- These three functions are simplified copies of those in HscMain, because
174 -- those functions are not exported. These versions have all error handling
176 hscParseType = hscParseThing Parser.parseType
177 hscParseStmt = hscParseThing Parser.parseStmt
179 hscParseThing :: Lexer.P thing -> DynFlags.DynFlags -> String -> GHC.Ghc thing
180 hscParseThing parser dflags str = do
181 buf <- MonadUtils.liftIO $ StringBuffer.stringToStringBuffer str
182 let loc = SrcLoc.mkSrcLoc (FastString.fsLit "<interactive>") 1 0
183 let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
186 -- | This function imports the module with the given name, for the renamer /
187 -- typechecker to use. It also imports any "orphans" and "family instances"
188 -- from modules included by this module, but not the actual modules
189 -- themselves. I'm not 100% sure how this works, but it seems that any
190 -- functions defined in included modules are available just by loading the
191 -- original module, and by doing this orphan stuff, any (type family or class)
192 -- instances are available as well.
194 -- Most of the code is based on tcRnImports and rnImportDecl, but those
195 -- functions do a lot more (which I hope we won't need...).
196 importModule :: Module.ModuleName -> TcRnTypes.RnM ()
197 importModule mod = do
198 let reason = Outputable.text "Hardcoded import" -- Used for trace output
200 -- Load the interface.
201 iface <- LoadIface.loadSrcInterface reason mod False pkg
202 -- Load orphan an familiy instance dependencies as well. I think these
203 -- dependencies are needed for the type checker to know all instances. Any
204 -- other instances (on other packages) are only useful to the
205 -- linker, so we can probably safely ignore them here. Dependencies within
206 -- the same package are also listed in deps, but I'm not so sure what to do
208 let deps = HscTypes.mi_deps iface
209 let orphs = HscTypes.dep_orphs deps
210 let finsts = HscTypes.dep_finsts deps
211 LoadIface.loadOrphanModules orphs False
212 LoadIface.loadOrphanModules finsts True