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