HsTools.hs

   1 {-# LANGUAGE ViewPatterns #-}
   2 module HsTools where
   3
   4 -- Standard modules
   5 import qualified Unsafe.Coerce
   6
   7
   8 -- GHC API
   9 import qualified GHC
  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
  41 import qualified Name
  42 import qualified TysWiredIn
  43 import qualified SrcLoc
  44 import qualified LoadIface
  45 import qualified BasicTypes
  46 import qualified Bag
  47 -- Core representation and handling
  48 import qualified CoreSyn
  49 import qualified Id
  50 import qualified Type
  51 import qualified TyCon
  52
  53
  54 -- Local imports
  55 import GhcTools
  56 import CoreShow
  57
  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
  64 --  let
  65 --    $dInt = ...
  66 --    (==) = Prelude.(==) Int $dInt
  67 --  in
  68 --    \x = (==) x 1
  69 toCore ::
  70   [Module.ModuleName] -- ^ The modules that need to be imported before translating
  71                       --   this expression.
  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
  75   env <- GHC.getSession
  76   let icontext = HscTypes.hsc_IC env
  77
  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
  86         -- Insts
  87         (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
  88         return res
  89       -- Translate the instances into bindings
  90       --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
  91       binds <- TcSimplify.tcSimplifyTop insts
  92       return (binds, tc_expr)
  93
  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)] [])
  98         tc_expr
  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
 102
 103   return desugar_expr
 104
 105 -- | Create an Id from a RdrName. Might not work for DataCons...
 106 mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
 107 mkId rdr_name = do
 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
 113       -- always work
 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.
 120         --
 121         -- Note that tcLookupId doesn't seem to work for DataCons. See source for
 122         -- tcLookupId to find out.
 123         TcEnv.tcLookupId name
 124   return id
 125
 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 (Type.splitTyConApp_maybe -> Just (tycon, tys)) =
 130   foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
 131   where
 132     tycon_name = TyCon.tyConName tycon
 133     mod_name = Module.moduleName $ Name.nameModule tycon_name
 134     occ_name = Name.nameOccName tycon_name
 135     tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
 136     tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
 137
 138 -- | Evaluate a CoreExpr and return its value. For this to work, the caller
 139 --   should already know the result type for sure, since the result value is
 140 --   unsafely coerced into this type.
 141 execCore :: CoreSyn.CoreExpr -> GHC.Ghc a
 142 execCore expr = do
 143         -- Setup session flags (yeah, this seems like a noop, but
 144         -- setSessionDynFlags really does some extra work...)
 145         dflags <- GHC.getSessionDynFlags
 146         GHC.setSessionDynFlags dflags
 147         -- Compile the expressions. This runs in the IO monad, but really wants
 148         -- to run an IO-monad-inside-a-GHC-monad for some reason. I don't really
 149         -- understand what it means, but it works.
 150         env <- GHC.getSession
 151         let srcspan = SrcLoc.mkGeneralSrcSpan (FastString.fsLit "XXX")
 152         hval <- MonadUtils.liftIO $ HscMain.compileExpr env srcspan expr
 153         let res = Unsafe.Coerce.unsafeCoerce hval :: Int
 154         return $ Unsafe.Coerce.unsafeCoerce hval
 155
 156 -- | Evaluate a core Type representing type level int from the TypeLevel
 157 -- library to a real int.
 158 eval_type_level_int :: Type.Type -> Int
 159 eval_type_level_int ty =
 160   unsafeRunGhc $ do
 161     -- Automatically import modules for any fully qualified identifiers
 162     setDynFlag DynFlags.Opt_ImplicitImportQualified
 163
 164     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
 165     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
 166     let undef = hsTypedUndef $ coreToHsType ty
 167     let app = HsExpr.HsApp (to_int) (undef)
 168
 169     core <- toCore [] app
 170     execCore core
 171
 172 -- These functions build (parts of) a LHSExpr RdrName.
 173
 174 -- | A reference to the Prelude.undefined function.
 175 hsUndef :: HsExpr.LHsExpr RdrName.RdrName
 176 hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
 177
 178 -- | A typed reference to the Prelude.undefined function.
 179 hsTypedUndef :: HsTypes.LHsType RdrName.RdrName -> HsExpr.LHsExpr RdrName.RdrName
 180 hsTypedUndef ty = SrcLoc.noLoc $ HsExpr.ExprWithTySig hsUndef ty
 181
 182 -- | Create a qualified RdrName from a module name and a variable name
 183 mkRdrName :: String -> String -> RdrName.RdrName
 184 mkRdrName mod var =
 185     RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
 186
 187 -- These three functions are simplified copies of those in HscMain, because
 188 -- those functions are not exported. These versions have all error handling
 189 -- removed.
 190 hscParseType = hscParseThing Parser.parseType
 191 hscParseStmt = hscParseThing Parser.parseStmt
 192
 193 hscParseThing :: Lexer.P thing -> DynFlags.DynFlags -> String -> GHC.Ghc thing
 194 hscParseThing parser dflags str = do
 195     buf <- MonadUtils.liftIO $ StringBuffer.stringToStringBuffer str
 196     let loc  = SrcLoc.mkSrcLoc (FastString.fsLit "<interactive>") 1 0
 197     let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
 198     return thing
 199
 200 -- | This function imports the module with the given name, for the renamer /
 201 -- typechecker to use. It also imports any "orphans" and "family instances"
 202 -- from modules included by this module, but not the actual modules
 203 -- themselves. I'm not 100% sure how this works, but it seems that any
 204 -- functions defined in included modules are available just by loading the
 205 -- original module, and by doing this orphan stuff, any (type family or class)
 206 -- instances are available as well.
 207 --
 208 -- Most of the code is based on tcRnImports and rnImportDecl, but those
 209 -- functions do a lot more (which I hope we won't need...).
 210 importModule :: Module.ModuleName -> TcRnTypes.RnM ()
 211 importModule mod = do
 212   let reason = Outputable.text "Hardcoded import" -- Used for trace output
 213   let pkg = Nothing
 214   -- Load the interface.
 215   iface <- LoadIface.loadSrcInterface reason mod False pkg
 216   -- Load orphan an familiy instance dependencies as well. I think these
 217   -- dependencies are needed for the type checker to know all instances. Any
 218   -- other instances (on other packages) are only useful to the
 219   -- linker, so we can probably safely ignore them here. Dependencies within
 220   -- the same package are also listed in deps, but I'm not so sure what to do
 221   -- with them.
 222   let deps = HscTypes.mi_deps iface
 223   let orphs = HscTypes.dep_orphs deps
 224   let finsts = HscTypes.dep_finsts deps
 225   LoadIface.loadOrphanModules orphs False
 226   LoadIface.loadOrphanModules finsts True