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
69 toCore :: HsSyn.HsExpr RdrName.RdrName -> GHC.Ghc CoreSyn.CoreExpr
72 let icontext = HscTypes.hsc_IC env
74 (binds, tc_expr) <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
75 -- Translage the TcRn (typecheck-rename) monad into an IO monad
76 TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
77 (tc_expr, insts) <- TcRnMonad.getLIE $ do
78 -- Rename the expression, resulting in a HsExpr Name
79 (rn_expr, freevars) <- RnExpr.rnExpr expr
80 -- Typecheck the expression, resulting in a HsExpr Id and a list of
82 (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
84 -- Translate the instances into bindings
85 --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
86 binds <- TcSimplify.tcSimplifyTop insts
87 return (binds, tc_expr)
89 -- Create a let expression with the extra binds (for polymorphism etc.) and
90 -- the resulting expression.
91 let letexpr = SrcLoc.noLoc $ HsExpr.HsLet
92 (HsBinds.HsValBinds $ HsBinds.ValBindsOut [(BasicTypes.NonRecursive, binds)] [])
94 -- Desugar the expression, resulting in core.
95 let rdr_env = HscTypes.ic_rn_gbl_env icontext
96 desugar_expr <- HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr
100 -- | Create an Id from a RdrName. Might not work for DataCons...
101 mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
103 env <- GHC.getSession
104 id <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
105 -- Translage the TcRn (typecheck-rename) monad in an IO monad
106 TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $
107 -- Automatically import all available modules, so fully qualified names
109 TcRnMonad.setOptM DynFlags.Opt_ImplicitImportQualified $ do
110 -- Lookup a Name for the RdrName. This finds the package (version) in
111 -- which the name resides.
112 name <- RnEnv.lookupGlobalOccRn rdr_name
113 -- Lookup an Id for the Name. This finds out the the type of the thing
114 -- we're looking for.
116 -- Note that tcLookupId doesn't seem to work for DataCons. See source for
117 -- tcLookupId to find out.
118 TcEnv.tcLookupId name
121 -- | Translate a core Type to an HsType. Far from complete so far.
122 coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
123 -- Translate TyConApps
124 coreToHsType (Type.splitTyConApp_maybe -> Just (tycon, tys)) =
125 foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
127 tycon_name = TyCon.tyConName tycon
128 mod_name = Module.moduleName $ Name.nameModule tycon_name
129 occ_name = Name.nameOccName tycon_name
130 tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
131 tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
133 -- | Evaluate a CoreExpr and return its value. For this to work, the caller
134 -- should already know the result type for sure, since the result value is
135 -- unsafely coerced into this type.
136 execCore :: CoreSyn.CoreExpr -> GHC.Ghc a
138 -- Setup session flags (yeah, this seems like a noop, but
139 -- setSessionDynFlags really does some extra work...)
140 dflags <- GHC.getSessionDynFlags
141 GHC.setSessionDynFlags dflags
142 -- Compile the expressions. This runs in the IO monad, but really wants
143 -- to run an IO-monad-inside-a-GHC-monad for some reason. I don't really
144 -- understand what it means, but it works.
145 env <- GHC.getSession
146 let srcspan = SrcLoc.mkGeneralSrcSpan (FastString.fsLit "XXX")
147 hval <- MonadUtils.liftIO $ HscMain.compileExpr env srcspan expr
148 let res = Unsafe.Coerce.unsafeCoerce hval :: Int
149 return $ Unsafe.Coerce.unsafeCoerce hval
151 -- | Evaluate a core Type representing type level int from the TypeLevel
152 -- library to a real int.
153 eval_type_level_int :: Type.Type -> Int
154 eval_type_level_int ty =
156 -- Automatically import modules for any fully qualified identifiers
157 setDynFlag DynFlags.Opt_ImplicitImportQualified
159 let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
160 let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
161 let undef = hsTypedUndef $ coreToHsType ty
162 let app = HsExpr.HsApp (to_int) (undef)
167 -- These functions build (parts of) a LHSExpr RdrName.
169 -- | A reference to the Prelude.undefined function.
170 hsUndef :: HsExpr.LHsExpr RdrName.RdrName
171 hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
173 -- | A typed reference to the Prelude.undefined function.
174 hsTypedUndef :: HsTypes.LHsType RdrName.RdrName -> HsExpr.LHsExpr RdrName.RdrName
175 hsTypedUndef ty = SrcLoc.noLoc $ HsExpr.ExprWithTySig hsUndef ty
177 -- | Create a qualified RdrName from a module name and a variable name
178 mkRdrName :: String -> String -> RdrName.RdrName
180 RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
182 -- These three functions are simplified copies of those in HscMain, because
183 -- those functions are not exported. These versions have all error handling
185 hscParseType = hscParseThing Parser.parseType
186 hscParseStmt = hscParseThing Parser.parseStmt
188 hscParseThing :: Lexer.P thing -> DynFlags.DynFlags -> String -> GHC.Ghc thing
189 hscParseThing parser dflags str = do
190 buf <- MonadUtils.liftIO $ StringBuffer.stringToStringBuffer str
191 let loc = SrcLoc.mkSrcLoc (FastString.fsLit "<interactive>") 1 0
192 let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
195 -- | This function imports the module with the given name, for the renamer /
196 -- typechecker to use. It also imports any "orphans" and "family instances"
197 -- from modules included by this module, but not the actual modules
198 -- themselves. I'm not 100% sure how this works, but it seems that any
199 -- functions defined in included modules are available just by loading the
200 -- original module, and by doing this orphan stuff, any (type family or class)
201 -- instances are available as well.
203 -- Most of the code is based on tcRnImports and rnImportDecl, but those
204 -- functions do a lot more (which I hope we won't need...).
205 importModule :: Module.ModuleName -> TcRnTypes.RnM ()
206 importModule mod = do
207 let reason = Outputable.text "Hardcoded import" -- Used for trace output
209 -- Load the interface.
210 iface <- LoadIface.loadSrcInterface reason mod False pkg
211 -- Load orphan an familiy instance dependencies as well. I think these
212 -- dependencies are needed for the type checker to know all instances. Any
213 -- other instances (on other packages) are only useful to the
214 -- linker, so we can probably safely ignore them here. Dependencies within
215 -- the same package are also listed in deps, but I'm not so sure what to do
217 let deps = HscTypes.mi_deps iface
218 let orphs = HscTypes.dep_orphs deps
219 let finsts = HscTypes.dep_finsts deps
220 LoadIface.loadOrphanModules orphs False
221 LoadIface.loadOrphanModules finsts True