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 -- 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
  37 import qualified Name
  38 import qualified SrcLoc
  39 import qualified BasicTypes
  40 -- Core representation and handling
  41 import qualified CoreSyn
  42 import qualified Id
  43 import qualified Type
  44 import qualified TyCon
  45
  46
  47 -- Local imports
  48 import GhcTools
  49 import CoreShow
  50
  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
  57 --  let
  58 --    $dInt = ...
  59 --    (==) = Prelude.(==) Int $dInt
  60 --  in
  61 --    \x = (==) x 1
  62 toCore :: HsSyn.HsExpr RdrName.RdrName -> GHC.Ghc CoreSyn.CoreExpr
  63 toCore expr = do
  64   env <- GHC.getSession
  65   let icontext = HscTypes.hsc_IC env
  66
  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
  74         -- Insts
  75         (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
  76         return res
  77       -- Translate the instances into bindings
  78       --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
  79       binds <- TcSimplify.tcSimplifyTop insts
  80       return (binds, tc_expr)
  81
  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)] [])
  86         tc_expr
  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
  90
  91   return desugar_expr
  92
  93 -- | Create an Id from a RdrName. Might not work for DataCons...
  94 mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
  95 mkId rdr_name = do
  96   env <- GHC.getSession
  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
 101       -- always work
 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.
 108         --
 109         -- Note that tcLookupId doesn't seem to work for DataCons. See source for
 110         -- tcLookupId to find out.
 111         TcEnv.tcLookupId name
 112   return id
 113
 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)
 119   where
 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
 125
 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
 130 execCore expr = do
 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
 143
 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 =
 148   unsafeRunGhc $ do
 149     -- Automatically import modules for any fully qualified identifiers
 150     setDynFlag DynFlags.Opt_ImplicitImportQualified
 151
 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)
 156
 157     core <- toCore app
 158     execCore core
 159
 160 -- These functions build (parts of) a LHSExpr RdrName.
 161
 162 -- | A reference to the Prelude.undefined function.
 163 hsUndef :: HsExpr.LHsExpr RdrName.RdrName
 164 hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
 165
 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
 169
 170 -- | Create a qualified RdrName from a module name and a variable name
 171 mkRdrName :: String -> String -> RdrName.RdrName
 172 mkRdrName mod var =
 173     RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
 174
 175 -- These three functions are simplified copies of those in HscMain, because
 176 -- those functions are not exported. These versions have all error handling
 177 -- removed.
 178 hscParseType = hscParseThing Parser.parseType
 179 hscParseStmt = hscParseThing Parser.parseStmt
 180
 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)
 186     return thing
 187