HsTools.hs

   1 {-# LANGUAGE ViewPatterns #-}
   2 module HsTools where
   3
   4 -- Standard modules
   5 import qualified Unsafe.Coerce
   6 import qualified Maybe
   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 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
  42 import qualified Name
  43 import qualified TysWiredIn
  44 import qualified SrcLoc
  45 import qualified LoadIface
  46 import qualified BasicTypes
  47 import qualified Bag
  48 -- Core representation and handling
  49 import qualified CoreSyn
  50 import qualified Id
  51 import qualified Type
  52 import qualified TyCon
  53
  54
  55 -- Local imports
  56 import GhcTools
  57 import CoreShow
  58
  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
  65 --  let
  66 --    $dInt = ...
  67 --    (==) = Prelude.(==) Int $dInt
  68 --  in
  69 --    \x = (==) x 1
  70 toCore ::
  71   [Module.ModuleName] -- ^ The modules that need to be imported before translating
  72                       --   this expression.
  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
  76   env <- GHC.getSession
  77   let icontext = HscTypes.hsc_IC env
  78
  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
  87         -- Insts
  88         (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
  89         return res
  90       -- Translate the instances into bindings
  91       --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
  92       binds <- TcSimplify.tcSimplifyTop insts
  93       return (binds, tc_expr)
  94
  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)] [])
  99         tc_expr
 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
 103
 104   return desugar_expr
 105
 106 -- | Create an Id from a RdrName. Might not work for DataCons...
 107 mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
 108 mkId rdr_name = do
 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
 114       -- always work
 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.
 121         --
 122         -- Note that tcLookupId doesn't seem to work for DataCons. See source for
 123         -- tcLookupId to find out.
 124         TcEnv.tcLookupId name
 125   return id
 126
 127 normaliseType ::
 128   HscTypes.HscEnv
 129   -> Type.Type
 130   -> IO Type.Type
 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
 137        return nty
 138    let normalized_ty = Maybe.fromJust nty
 139    return normalized_ty
 140
 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
 145   Just (tycon, tys) ->
 146     foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
 147     where
 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"
 154
 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
 159 execCore expr = do
 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
 172
 173 -- These functions build (parts of) a LHSExpr RdrName.
 174
 175 -- | A reference to the Prelude.undefined function.
 176 hsUndef :: HsExpr.LHsExpr RdrName.RdrName
 177 hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
 178
 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
 182
 183 -- | Create a qualified RdrName from a module name and a variable name
 184 mkRdrName :: String -> String -> RdrName.RdrName
 185 mkRdrName mod var =
 186     RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
 187
 188 -- These three functions are simplified copies of those in HscMain, because
 189 -- those functions are not exported. These versions have all error handling
 190 -- removed.
 191 hscParseType = hscParseThing Parser.parseType
 192 hscParseStmt = hscParseThing Parser.parseStmt
 193
 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)
 199     return thing
 200
 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.
 208 --
 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
 214   let pkg = Nothing
 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
 222   -- with them.
 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