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 -- Lexer & Parser, i.e. up to HsExpr
18 import qualified Lexer
19 import qualified Parser
20 -- HsExpr representation, renaming, typechecking and desugaring
21 -- (i.e., everything up to Core).
22 import qualified HsSyn
23 import qualified HsExpr
24 import qualified HsTypes
25 import qualified HsBinds
26 import qualified TcRnMonad
27 import qualified RnExpr
28 import qualified RnEnv
29 import qualified TcExpr
30 import qualified TcEnv
31 import qualified TcSimplify
32 import qualified Desugar
33 import qualified PrelNames
34 import qualified Module
35 import qualified OccName
36 import qualified RdrName
38 import qualified SrcLoc
39 import qualified BasicTypes
40 -- Core representation and handling
41 import qualified CoreSyn
44 import qualified TyCon
51 -- | Translate a HsExpr to a Core expression. This does renaming, type
52 -- checking, simplification of class instances and desugaring. The result is
53 -- a let expression that holds the given expression and a number of binds that
54 -- are needed for any type classes used to work. For example, the HsExpr:
55 -- \x = x == (1 :: Int)
56 -- will result in the CoreExpr
59 -- (==) = Prelude.(==) Int $dInt
62 toCore :: HsSyn.HsExpr RdrName.RdrName -> GHC.Ghc CoreSyn.CoreExpr
65 let icontext = HscTypes.hsc_IC env
67 (binds, tc_expr) <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
68 -- Translage the TcRn (typecheck-rename) monad into an IO monad
69 TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
70 (tc_expr, insts) <- TcRnMonad.getLIE $ do
71 -- Rename the expression, resulting in a HsExpr Name
72 (rn_expr, freevars) <- RnExpr.rnExpr expr
73 -- Typecheck the expression, resulting in a HsExpr Id and a list of
75 (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
77 -- Translate the instances into bindings
78 --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
79 binds <- TcSimplify.tcSimplifyTop insts
80 return (binds, tc_expr)
82 -- Create a let expression with the extra binds (for polymorphism etc.) and
83 -- the resulting expression.
84 let letexpr = SrcLoc.noLoc $ HsExpr.HsLet
85 (HsBinds.HsValBinds $ HsBinds.ValBindsOut [(BasicTypes.NonRecursive, binds)] [])
87 -- Desugar the expression, resulting in core.
88 let rdr_env = HscTypes.ic_rn_gbl_env icontext
89 desugar_expr <- HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr
93 -- | Create an Id from a RdrName. Might not work for DataCons...
94 mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
97 id <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
98 -- Translage the TcRn (typecheck-rename) monad in an IO monad
99 TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $
100 -- Automatically import all available modules, so fully qualified names
102 TcRnMonad.setOptM DynFlags.Opt_ImplicitImportQualified $ do
103 -- Lookup a Name for the RdrName. This finds the package (version) in
104 -- which the name resides.
105 name <- RnEnv.lookupGlobalOccRn rdr_name
106 -- Lookup an Id for the Name. This finds out the the type of the thing
107 -- we're looking for.
109 -- Note that tcLookupId doesn't seem to work for DataCons. See source for
110 -- tcLookupId to find out.
111 TcEnv.tcLookupId name
114 -- | Translate a core Type to an HsType. Far from complete so far.
115 coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
116 -- Translate TyConApps
117 coreToHsType (Type.splitTyConApp_maybe -> Just (tycon, tys)) =
118 foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
120 tycon_name = TyCon.tyConName tycon
121 mod_name = Module.moduleName $ Name.nameModule tycon_name
122 occ_name = Name.nameOccName tycon_name
123 tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
124 tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
126 -- | Evaluate a CoreExpr and return its value. For this to work, the caller
127 -- should already know the result type for sure, since the result value is
128 -- unsafely coerced into this type.
129 execCore :: CoreSyn.CoreExpr -> GHC.Ghc a
131 -- Setup session flags (yeah, this seems like a noop, but
132 -- setSessionDynFlags really does some extra work...)
133 dflags <- GHC.getSessionDynFlags
134 GHC.setSessionDynFlags dflags
135 -- Compile the expressions. This runs in the IO monad, but really wants
136 -- to run an IO-monad-inside-a-GHC-monad for some reason. I don't really
137 -- understand what it means, but it works.
138 env <- GHC.getSession
139 let srcspan = SrcLoc.mkGeneralSrcSpan (FastString.fsLit "XXX")
140 hval <- MonadUtils.liftIO $ HscMain.compileExpr env srcspan expr
141 let res = Unsafe.Coerce.unsafeCoerce hval :: Int
142 return $ Unsafe.Coerce.unsafeCoerce hval
144 -- | Evaluate a core Type representing type level int from the TypeLevel
145 -- library to a real int.
146 eval_type_level_int :: Type.Type -> Int
147 eval_type_level_int ty =
149 -- Automatically import modules for any fully qualified identifiers
150 setDynFlag DynFlags.Opt_ImplicitImportQualified
152 let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
153 let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
154 let undef = hsTypedUndef $ coreToHsType ty
155 let app = HsExpr.HsApp (to_int) (undef)
160 -- These functions build (parts of) a LHSExpr RdrName.
162 -- | A reference to the Prelude.undefined function.
163 hsUndef :: HsExpr.LHsExpr RdrName.RdrName
164 hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
166 -- | A typed reference to the Prelude.undefined function.
167 hsTypedUndef :: HsTypes.LHsType RdrName.RdrName -> HsExpr.LHsExpr RdrName.RdrName
168 hsTypedUndef ty = SrcLoc.noLoc $ HsExpr.ExprWithTySig hsUndef ty
170 -- | Create a qualified RdrName from a module name and a variable name
171 mkRdrName :: String -> String -> RdrName.RdrName
173 RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
175 -- These three functions are simplified copies of those in HscMain, because
176 -- those functions are not exported. These versions have all error handling
178 hscParseType = hscParseThing Parser.parseType
179 hscParseStmt = hscParseThing Parser.parseStmt
181 hscParseThing :: Lexer.P thing -> DynFlags.DynFlags -> String -> GHC.Ghc thing
182 hscParseThing parser dflags str = do
183 buf <- MonadUtils.liftIO $ StringBuffer.stringToStringBuffer str
184 let loc = SrcLoc.mkSrcLoc (FastString.fsLit "<interactive>") 1 0
185 let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)