cλash/CLasH/Utils/HsTools.hs

   1 module CLasH.Utils.HsTools where
   2
   3 -- Standard modules
   4 import qualified Unsafe.Coerce
   5 import qualified Maybe
   6
   7 -- GHC API
   8 import qualified GHC
   9 import qualified HscMain
  10 import qualified HscTypes
  11 import qualified DynFlags
  12 import qualified FastString
  13 import qualified StringBuffer
  14 import qualified MonadUtils
  15 import Outputable ( showSDoc, ppr )
  16 import qualified Outputable
  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 TcRnTypes
  28 import qualified RnExpr
  29 import qualified RnEnv
  30 import qualified TcExpr
  31 import qualified TcEnv
  32 import qualified TcSimplify
  33 import qualified TcTyFuns
  34 import qualified Desugar
  35 import qualified PrelNames
  36 import qualified Module
  37 import qualified OccName
  38 import qualified RdrName
  39 import qualified Name
  40 import qualified SrcLoc
  41 import qualified LoadIface
  42 import qualified BasicTypes
  43 -- Core representation and handling
  44 import qualified CoreSyn
  45 import qualified Id
  46 import qualified Type
  47 import qualified TyCon
  48
  49 -- | Translate a HsExpr to a Core expression. This does renaming, type
  50 -- checking, simplification of class instances and desugaring. The result is
  51 -- a let expression that holds the given expression and a number of binds that
  52 -- are needed for any type classes used to work. For example, the HsExpr:
  53 --  \x = x == (1 :: Int)
  54 -- will result in the CoreExpr
  55 --  let
  56 --    $dInt = ...
  57 --    (==) = Prelude.(==) Int $dInt
  58 --  in
  59 --    \x = (==) x 1
  60 toCore ::
  61   HsSyn.HsExpr RdrName.RdrName -- ^ The expression to translate to Core.
  62   -> GHC.Ghc CoreSyn.CoreExpr -- ^ The resulting core expression.
  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   HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr
  90
  91
  92 -- | Create an Id from a RdrName. Might not work for DataCons...
  93 mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
  94 mkId rdr_name = do
  95   env <- GHC.getSession
  96   HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
  97     -- Translage the TcRn (typecheck-rename) monad in an IO monad
  98     TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $
  99       -- Automatically import all available modules, so fully qualified names
 100       -- always work
 101       TcRnMonad.setOptM DynFlags.Opt_ImplicitImportQualified $ do
 102         -- Lookup a Name for the RdrName. This finds the package (version) in
 103         -- which the name resides.
 104         name <- RnEnv.lookupGlobalOccRn rdr_name
 105         -- Lookup an Id for the Name. This finds out the the type of the thing
 106         -- we're looking for.
 107         --
 108         -- Note that tcLookupId doesn't seem to work for DataCons. See source for
 109         -- tcLookupId to find out.
 110         TcEnv.tcLookupId name
 111
 112 normaliseType ::
 113   HscTypes.HscEnv
 114   -> Type.Type
 115   -> IO Type.Type
 116 normaliseType env ty = do
 117    (err, nty) <- MonadUtils.liftIO $
 118      -- Initialize the typechecker monad
 119      TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
 120        -- Normalize the type
 121        (_, nty) <- TcTyFuns.tcNormaliseFamInst ty
 122        return nty
 123    let normalized_ty = Maybe.fromJust nty
 124    return normalized_ty
 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 ty = case Type.splitTyConApp_maybe ty of
 130   Just (tycon, tys) ->
 131     foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
 132     where
 133       tycon_name = TyCon.tyConName tycon
 134       mod_name = Module.moduleName $ Name.nameModule tycon_name
 135       occ_name = Name.nameOccName tycon_name
 136       tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
 137       tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
 138   Nothing -> error "HsTools.coreToHsType Cannot translate non-tycon type"
 139
 140 -- | Evaluate a CoreExpr and return its value. For this to work, the caller
 141 --   should already know the result type for sure, since the result value is
 142 --   unsafely coerced into this type.
 143 execCore :: CoreSyn.CoreExpr -> GHC.Ghc a
 144 execCore expr = do
 145         -- Setup session flags (yeah, this seems like a noop, but
 146         -- setSessionDynFlags really does some extra work...)
 147         dflags <- GHC.getSessionDynFlags
 148         GHC.setSessionDynFlags dflags
 149         -- Compile the expressions. This runs in the IO monad, but really wants
 150         -- to run an IO-monad-inside-a-GHC-monad for some reason. I don't really
 151         -- understand what it means, but it works.
 152         env <- GHC.getSession
 153         let srcspan = SrcLoc.noSrcSpan
 154         hval <- MonadUtils.liftIO $ HscMain.compileExpr env srcspan expr
 155         let res = Unsafe.Coerce.unsafeCoerce hval :: Int
 156         return $ Unsafe.Coerce.unsafeCoerce hval
 157
 158 -- These functions build (parts of) a LHSExpr RdrName.
 159
 160 -- | A reference to the Prelude.undefined function.
 161 hsUndef :: HsExpr.LHsExpr RdrName.RdrName
 162 hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
 163
 164 -- | A typed reference to the Prelude.undefined function.
 165 hsTypedUndef :: HsTypes.LHsType RdrName.RdrName -> HsExpr.LHsExpr RdrName.RdrName
 166 hsTypedUndef ty = SrcLoc.noLoc $ HsExpr.ExprWithTySig hsUndef ty
 167
 168 -- | Create a qualified RdrName from a module name and a variable name
 169 mkRdrName :: String -> String -> RdrName.RdrName
 170 mkRdrName mod var =
 171     RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
 172
 173 -- These three functions are simplified copies of those in HscMain, because
 174 -- those functions are not exported. These versions have all error handling
 175 -- removed.
 176 hscParseType = hscParseThing Parser.parseType
 177 hscParseStmt = hscParseThing Parser.parseStmt
 178
 179 hscParseThing :: Lexer.P thing -> DynFlags.DynFlags -> String -> GHC.Ghc thing
 180 hscParseThing parser dflags str = do
 181     buf <- MonadUtils.liftIO $ StringBuffer.stringToStringBuffer str
 182     let loc  = SrcLoc.mkSrcLoc (FastString.fsLit "<interactive>") 1 0
 183     let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
 184     return thing
 185
 186 -- | This function imports the module with the given name, for the renamer /
 187 -- typechecker to use. It also imports any "orphans" and "family instances"
 188 -- from modules included by this module, but not the actual modules
 189 -- themselves. I'm not 100% sure how this works, but it seems that any
 190 -- functions defined in included modules are available just by loading the
 191 -- original module, and by doing this orphan stuff, any (type family or class)
 192 -- instances are available as well.
 193 --
 194 -- Most of the code is based on tcRnImports and rnImportDecl, but those
 195 -- functions do a lot more (which I hope we won't need...).
 196 importModule :: Module.ModuleName -> TcRnTypes.RnM ()
 197 importModule mod = do
 198   let reason = Outputable.text "Hardcoded import" -- Used for trace output
 199   let pkg = Nothing
 200   -- Load the interface.
 201   iface <- LoadIface.loadSrcInterface reason mod False pkg
 202   -- Load orphan an familiy instance dependencies as well. I think these
 203   -- dependencies are needed for the type checker to know all instances. Any
 204   -- other instances (on other packages) are only useful to the
 205   -- linker, so we can probably safely ignore them here. Dependencies within
 206   -- the same package are also listed in deps, but I'm not so sure what to do
 207   -- with them.
 208   let deps = HscTypes.mi_deps iface
 209   let orphs = HscTypes.dep_orphs deps
 210   let finsts = HscTypes.dep_finsts deps
 211   LoadIface.loadOrphanModules orphs False
 212   LoadIface.loadOrphanModules finsts True