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