-- Standard modules
import qualified Unsafe.Coerce
-
+import qualified Maybe
-- GHC API
import qualified GHC
import qualified TcExpr
import qualified TcEnv
import qualified TcSimplify
+import qualified TcTyFuns
import qualified Desugar
import qualified InstEnv
import qualified FamInstEnv
-- (==) = Prelude.(==) Int $dInt
-- in
-- \x = (==) x 1
-toCore ::
- [Module.ModuleName] -- ^ The modules that need to be imported before translating
- -- this expression.
- -> HsSyn.HsExpr RdrName.RdrName -- ^ The expression to translate to Core.
+toCore ::
+ HsSyn.HsExpr RdrName.RdrName -- ^ The expression to translate to Core.
-> GHC.Ghc CoreSyn.CoreExpr -- ^ The resulting core expression.
-toCore modules expr = do
+toCore expr = do
env <- GHC.getSession
let icontext = HscTypes.hsc_IC env
-- Translage the TcRn (typecheck-rename) monad into an IO monad
TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
(tc_expr, insts) <- TcRnMonad.getLIE $ do
- mapM importModule modules
-- Rename the expression, resulting in a HsExpr Name
(rn_expr, freevars) <- RnExpr.rnExpr expr
-- Typecheck the expression, resulting in a HsExpr Id and a list of
TcEnv.tcLookupId name
return id
+normaliseType ::
+ HscTypes.HscEnv
+ -> Type.Type
+ -> IO Type.Type
+normaliseType env ty = do
+ (err, nty) <- MonadUtils.liftIO $
+ -- Initialize the typechecker monad
+ TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
+ -- Normalize the type
+ (_, nty) <- TcTyFuns.tcNormaliseFamInst ty
+ return nty
+ let normalized_ty = Maybe.fromJust nty
+ return normalized_ty
+
-- | Translate a core Type to an HsType. Far from complete so far.
coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
-- Translate TyConApps
-coreToHsType (Type.splitTyConApp_maybe -> Just (tycon, tys)) =
- foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
- where
- tycon_name = TyCon.tyConName tycon
- mod_name = Module.moduleName $ Name.nameModule tycon_name
- occ_name = Name.nameOccName tycon_name
- tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
- tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
+coreToHsType ty = case Type.splitTyConApp_maybe ty of
+ Just (tycon, tys) ->
+ foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
+ where
+ tycon_name = TyCon.tyConName tycon
+ mod_name = Module.moduleName $ Name.nameModule tycon_name
+ occ_name = Name.nameOccName tycon_name
+ tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
+ tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
+ Nothing -> error $ "HsTools.coreToHsType Cannot translate non-tycon type"
-- | Evaluate a CoreExpr and return its value. For this to work, the caller
-- should already know the result type for sure, since the result value is