-- 
-- (c) Susumu Katayama
--
{-# LANGUAGE TemplateHaskell, MagicHash, CPP, TypeFamilies, FlexibleContexts #-}
-- TypeFamilies is only necessary with ghc>=8.6
-- compile with  -package ghc
module MagicHaskeller.ExecuteAPI610  {- (loadObj, prepareAPI, executeAPI, unsafeExecuteAPI) -} where
import qualified HscMain
import GHC
import GHC.Exts
import GHC.Paths(libdir) -- as instructed in http://haskell.org/haskellwiki/GHC/As_a_library
import DynFlags         -- (DynFlag, defaultDynFlags, PackageFlag(ExposePackage)) -- , glasgowExtsFlags) はexportされていないらしい.
import SrcLoc           (SrcSpan(..), noSrcSpan, noSrcLoc, interactiveSrcLoc, noLoc)

-- import MyCorePrep( corePrepExpr )
import CorePrep(corePrepExpr) -- コンパイルが通らないのでオリジナルにしてみる

import FastString
import ByteCodeGen      ( coreExprToBCOs )

-- import MyLink                -- ( HValue, linkExpr, initDynLinker )
import Linker -- コンパイルが通らないのでオリジナルにしてみる

-- import Flattening
import HscTypes        -- ( HscEnv(..), Session(..), withSession, InteractiveContext(..), mkTypeEnv ) -- also import instance MonadIO Ghc
import SimplCore
-- import SimplOnce -- コンパイルが通らないのでコメントアウト
import VarEnv           ( emptyTidyEnv )
import CoreSyn          ( CoreExpr, Expr(..), Bind(..) )     -- compiler/coreSyn/CoreSyn.lhs
import CoreTidy         ( tidyExpr )


import Parser           (parseStmt)
import Lexer
import TcRnDriver        ( tcRnStmt, tcRnExpr, tcRnType )
import Desugar          (deSugarExpr)
#if __GLASGOW_HASKELL__ < 708
import PrelNames        ( iNTERACTIVE )
#else
import PrelNames        (mkInteractiveModule)
#endif
import ErrUtils
import StringBuffer     (stringToStringBuffer)
import Outputable       (ppr, pprPanic, showSDocDebug, showSDoc)
#if __GLASGOW_HASKELL__ < 706
import Type             (pprType, Type)
#else
import Type             (Type)
#endif

import CoreLint         (lintUnfolding)
-- import VarSet           (varSetElems)
import Panic            (panic)

import Var              -- (Var(..))

import System.IO
import System.IO.Unsafe

import Data.IORef

import System.Exit
import Control.Monad(when)
-- import Control.Monad.Trans(liftIO)

import MagicHaskeller.MyDynamic
import qualified MagicHaskeller.CoreLang as CoreLang
import Language.Haskell.TH as TH hiding (ppr)

import Data.List(isSuffixOf)

#ifdef GHC6
-- prelude/TysPrim.
import TysPrim(anyPrimTy)
#endif

import Bag
import RdrName
import OccName
#if __GLASGOW_HASKELL__ >= 810
import BasicTypes
import GHC.ThToHs
import GHC.Hs.Binds -- was HsBinds
#else
import Convert
#endif
import HsUtils
import HsExpr

-- 最後のCoreExpr ---> CoreExprで要るもの．
import IdInfo
import Data.Char(ord,chr)
import qualified Data.Map as Map
import qualified MagicHaskeller.Types as Types
import Data.List
import Unique
import Id

import UniqSupply

import ByteCodeLink(linkBCO,extendClosureEnv)
#ifdef PRELINK
# if __GLASGOW_HASKELL__ >= 800
import ByteCodeTypes(UnlinkedBCO(unlinkedBCOName))
# else
import ByteCodeAsm(UnlinkedBCO(unlinkedBCOName))
# endif
#endif
# if __GLASGOW_HASKELL__ >= 800
import GHCi(wormhole)
#endif

import Data.Array

-- #define PRELINK

pathToGHC :: FilePath    -- path to GHC, e.g. "/usr/lib/ghc-6.10.4". 'libdir' can be used instead.
pathToGHC :: FilePath
pathToGHC = FilePath
libdir

loadObj :: [String] -- ^ visible modules (including package modules). You may omit the Prelude.
           -> IO (CoreLang.VarLib -> CoreLang.CoreExpr -> Dynamic)
loadObj :: [FilePath] -> IO (VarLib -> CoreExpr -> Dynamic)
loadObj [FilePath]
fss = (HscEnv -> VarLib -> CoreExpr -> Dynamic)
-> IO HscEnv -> IO (VarLib -> CoreExpr -> Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HscEnv -> VarLib -> CoreExpr -> Dynamic
unsafeExecuteAPI (IO HscEnv -> IO (VarLib -> CoreExpr -> Dynamic))
-> IO HscEnv -> IO (VarLib -> CoreExpr -> Dynamic)
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath] -> IO HscEnv
prepareAPI [] [FilePath]
fss

-- Just follow http://haskell.org/haskellwiki/GHC/As_a_library
-- 問題は，すでに読まれているmoduleはどうするかってことだけど，:loadコマンド同様再読み込み
-- addNonPackageTargetってのを定義したので，分ける必要はなくなったはず．
prepareAPI :: [FilePath] -- ^ modules to be loaded (except package modules)
           -> [FilePath] -- ^ visible modules (including package modules)
           -> IO HscEnv
prepareAPI :: [FilePath] -> [FilePath] -> IO HscEnv
prepareAPI [FilePath]
loadfss [FilePath]
visfss
{-
prepareAPI :: [String] -- ^ visible modules (including package modules). 
                       --   Supplying @[]@ here works without any problems within GHCi, and currently @prepareAPI@ does not work without --interactive, 
                       --   so this argument is actually of no use:(
           -> IO HscEnv
prepareAPI fss
-}
#if __GLASGOW_HASKELL__ >= 700
# if __GLASGOW_HASKELL__ >= 706
    = FatalMessager -> FlushOut -> IO HscEnv -> IO HscEnv
forall (m :: * -> *) a.
ExceptionMonad m =>
FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler FatalMessager
defaultFatalMessager FlushOut
defaultFlushOut (IO HscEnv -> IO HscEnv) -> IO HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
# else
    = defaultErrorHandler defaultLogAction $
# endif
#else
    = defaultErrorHandler defaultDynFlags $
#endif
      Maybe FilePath -> Ghc HscEnv -> IO HscEnv
forall a. Maybe FilePath -> Ghc a -> IO a
runGhc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
pathToGHC) (Ghc HscEnv -> IO HscEnv) -> Ghc HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ do
          -- liftIO $ hPutStrLn stderr "setting up flags"

          DynFlags
dfs     <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
--          when (flags dfs /= flags defaultDynFlags) $ error "flags are different"
          let newf :: DynFlags
newf = DynFlags
dfs{ -- opt_P = "-DTEMPLATE_HASKELL" : "-DCLASSIFY" : "-DCHTO" : opt_P dfs,           -- defaultDynFlagsのソースが結構参考になったり．
                         packageFlags :: [PackageFlag]
packageFlags = [ FilePath -> PackageFlag
packageNameToFlag FilePath
"ghc", FilePath -> PackageFlag
packageNameToFlag FilePath
"old-time", FilePath -> PackageFlag
packageNameToFlag FilePath
"ghc-paths" ] -- , packageNameToFlag "MagicHaskeller" ]
                         {-
                         flags = Opt_TemplateHaskell  : Opt_Cpp : -- Opt_FlexibleInstances : Opt_ExistentialQuantification : Opt_PolymorphicComponents : Opt_RelaxedPolyRec :
                                 Opt_MagicHash :
                                 Opt_RankNTypes :
                                 filter (/=Opt_MonomorphismRestriction) (flags dfs) -}
                        } -- Was: Opt_TH   --  てゆーか，LibTHをここで読むにはいろんなフラグが....
          DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
newf   -- result abandoned
          -- ソースによると結果はDynamic linkingの時に必要ってことだけど，ま，基本的にはDynamic linkingはunsupportedってことか．
          -- http://hackage.haskell.org/trac/ghc/wiki/DynamicLinking
          -- ...違う．そのdynamic linkingではない．

          -- liftIO $ hPutStrLn stderr "loading modules" -- This IS necessary.
          [Target]
ts <- (FilePath -> Ghc Target) -> [FilePath] -> Ghc [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\FilePath
fs -> FilePath -> Maybe Phase -> Ghc Target
forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe Phase -> m Target
guessTarget FilePath
fs Maybe Phase
forall a. Maybe a
Nothing) [FilePath]
loadfss
          [Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
ts
          SuccessFlag
sf <- DynFlags -> Ghc SuccessFlag -> Ghc SuccessFlag
forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
defaultCleanupHandler DynFlags
newf (LoadHowMuch -> Ghc SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
LoadAllTargets)
          case SuccessFlag
sf of SuccessFlag
Succeeded -> () -> Ghc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                     SuccessFlag
Failed    -> FilePath -> Ghc ()
forall a. HasCallStack => FilePath -> a
error FilePath
"failed to load modules"

          -- liftIO $ hPutStrLn stderr "setting up modules"
-- Same lines (except visfss) appear in SimpleServer.hs. Consider defining a function. Note that this module would not be imported when Flag GHCAPI is False.
#if __GLASGOW_HASKELL__ >= 700
          [(Module, Maybe Any)]
modules <- (FilePath -> Ghc (Module, Maybe Any))
-> [FilePath] -> Ghc [(Module, Maybe Any)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\FilePath
fs -> (Module -> (Module, Maybe Any))
-> Ghc Module -> Ghc (Module, Maybe Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Module
x -> (Module
x,Maybe Any
forall a. Maybe a
Nothing)) (Ghc Module -> Ghc (Module, Maybe Any))
-> Ghc Module -> Ghc (Module, Maybe Any)
forall a b. (a -> b) -> a -> b
$ ModuleName -> Maybe FastString -> Ghc Module
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
findModule (FilePath -> ModuleName
mkModuleName FilePath
fs) Maybe FastString
forall a. Maybe a
Nothing) (FilePath
"Prelude"FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
visfss)
# if __GLASGOW_HASKELL__ >= 802
          [InteractiveImport] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext [ ImportDecl GhcPs -> InteractiveImport
IIDecl (ImportDecl GhcPs -> InteractiveImport)
-> ImportDecl GhcPs -> InteractiveImport
forall a b. (a -> b) -> a -> b
$ (ModuleName -> ImportDecl GhcPs
forall (p :: Pass). ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl (ModuleName -> ImportDecl GhcPs)
-> (FilePath -> ModuleName) -> FilePath -> ImportDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ModuleName
mkModuleName (FilePath -> ImportDecl GhcPs) -> FilePath -> ImportDecl GhcPs
forall a b. (a -> b) -> a -> b
$ FilePath
moduleName) | FilePath
moduleName <- FilePath
"Prelude"FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
visfss ] -- idelcQualified of simpleImportDecl is False at least since 8.2, and becomes ImportDeclQualifiedStyle at ghc-api-compat
# else
          setContext [ IIDecl $ (simpleImportDecl . mkModuleName $ moduleName){GHC.ideclQualified = False} | moduleName <- "Prelude":visfss ] -- GHC 7.4
# endif
#else
          modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":visfss)
          setContext [] modules
#endif

#ifdef PRELINK
          -- prelink!
          newdfs     <- getSessionDynFlags
          initDynLinker newdfs
#endif

          Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

packageNameToFlag :: String -> PackageFlag
#if __GLASGOW_HASKELL__ < 710
packageNameToFlag = ExposePackage
#else
# if __GLASGOW_HASKELL__ < 800
packageNameToFlag name = ExposePackage (PackageArg name) (ModRenaming False []) -- I am not sure this is the correct conversion, because I could not find any documentation on the change.
# else
packageNameToFlag :: FilePath -> PackageFlag
packageNameToFlag FilePath
name = FilePath -> PackageArg -> ModRenaming -> PackageFlag
ExposePackage (FilePath
"-package "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
name) (FilePath -> PackageArg
PackageArg FilePath
name) (Bool -> [(ModuleName, ModuleName)] -> ModRenaming
ModRenaming Bool
False []) -- I am not sure this is the correct conversion, because I could not find any documentation on the change.
# endif
#endif

{-
-- | @addNonPackageTarget@ adds a target only if the target is not a package module.
--   This function assumes there is no package module in the target set of the session.
addNonPackageTarget :: Target -> IO ()
addNonPackageTarget target@(Target targetid _)
    = catchDyn (addTarget target >> depanal [] False >> return ())
               (\str -> if "is a package module" `isSuffixOf` str then removeTarget targetid else throwDyn str)
-- depanalがNothingを返す場合，結局後のloadがfailする訳だが，面倒なのでこの段階では放置プレイってことで．
-}

-- At least I should use a customized version of toString....
unsafeExecuteAPI :: HscEnv -> CoreLang.VarLib -> CoreLang.CoreExpr -> Dynamic
unsafeExecuteAPI :: HscEnv -> VarLib -> CoreExpr -> Dynamic
unsafeExecuteAPI HscEnv
session VarLib
vl CoreExpr
cece = TyConLib -> Type -> Any -> Any -> Dynamic
forall a e. TyConLib -> Type -> a -> e -> Dynamic
unsafeToDyn TyConLib
forall a. HasCallStack => a
undefined Type
forall a. HasCallStack => a
undefined (Any -> Any
unsafeCoerce# (Any -> Any) -> Any -> Any
forall a b. (a -> b) -> a -> b
$ IO Any -> Any
forall a. IO a -> a
unsafePerformIO (IO Any -> Any) -> IO Any -> Any
forall a b. (a -> b) -> a -> b
$ HscEnv -> VarLib -> CoreExpr -> IO Any
forall a. HscEnv -> VarLib -> CoreExpr -> IO a
executeAPI HscEnv
session VarLib
vl CoreExpr
cece) Any
forall a. HasCallStack => a
undefined -- unsafeCoerce# is necessary to convert from Dynamic.HValue to HValue.
executeAPI :: HscEnv -> CoreLang.VarLib -> CoreLang.CoreExpr -> IO a
executeAPI :: HscEnv -> VarLib -> CoreExpr -> IO a
executeAPI HscEnv
session VarLib
vl CoreExpr
cece = HscEnv -> Exp -> IO a
forall a. HscEnv -> Exp -> IO a
executeTHExp HscEnv
session (VarLib -> CoreExpr -> Exp
CoreLang.exprToTHExp VarLib
vl CoreExpr
cece)
executeTHExp :: HscEnv -> TH.Exp -> IO a
executeTHExp :: HscEnv -> Exp -> IO a
executeTHExp HscEnv
session Exp
the = HscEnv -> CoreExpr -> IO a
forall a. HscEnv -> CoreExpr -> IO a
unwrapCore HscEnv
session (CoreExpr -> IO a) -> IO CoreExpr -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HscEnv -> Exp -> IO CoreExpr
compileCoreExpr HscEnv
session Exp
the


compileCoreExpr ::  HscEnv -> TH.Exp -> IO CoreSyn.CoreExpr 
compileCoreExpr :: HscEnv -> Exp -> IO CoreExpr
compileCoreExpr HscEnv
hscEnv Exp
the
    = -- defaultErrorHandler defaultDynFlags $ -- thread killed を表示させたい場合はこっち．
{-
       do res <- compileExpr session $ TH.pprint $ CoreLang.exprToTHExp cece
          case res of Nothing -> hPutStrLn stderr "Could not execute" >> error "could not execute"
                      Just hv -> return hv
-}


--       do mbt <- strToCore hscEnv ("let __cmCompileExpr = " ++ TH.pprint the)

       do Maybe ([Id], CoreExpr)
mbt <- HscEnv -> GhciLStmt GhcPs -> IO (Maybe ([Id], CoreExpr))
stmtToCore HscEnv
hscEnv (GhciLStmt GhcPs -> IO (Maybe ([Id], CoreExpr)))
-> GhciLStmt GhcPs -> IO (Maybe ([Id], CoreExpr))
forall a b. (a -> b) -> a -> b
$ HscEnv -> Exp -> GhciLStmt GhcPs
thExpToStmt HscEnv
hscEnv Exp
the
          case Maybe ([Id], CoreExpr)
mbt of Maybe ([Id], CoreExpr)
Nothing -> FilePath -> IO CoreExpr
forall a. HasCallStack => FilePath -> a
error (FilePath
"could not compile " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Exp -> FilePath
forall a. Ppr a => a -> FilePath
TH.pprint Exp
the FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to core.")
                      Just ([Id
i ], CoreExpr
ce) -> CoreExpr -> IO CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
ce


-- unwrapCore, unwrapCore' の両方が正しく動く．unwrapCoreはghc6.8で動いていたのを持ってきたもので，compileExprHscMainの方をコメントアウトしてrunCoreExprにすると色々はしょる代わりに正しく動かない．
unwrapCore :: HscEnv -> CoreSyn.CoreExpr -> IO a
unwrapCore :: HscEnv -> CoreExpr -> IO a
unwrapCore HscEnv
hscEnv CoreExpr
ce =                  do -- iohvs <- runCoreExpr hscEnv ce -- (removeIdInfo ce)
                                           IO [a]
iohvs <- IO HValue -> IO (IO [a])
unsafeCoerce# (IO HValue -> IO (IO [a])) -> IO HValue -> IO (IO [a])
forall a b. (a -> b) -> a -> b
$ HscEnv -> CoreExpr -> IO HValue
compileExprHscMain HscEnv
hscEnv CoreExpr
ce
                                           [a
hv] <- IO [a]
iohvs
                                           a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
hv

-- unwrapCore' hscEnv ce = fmap head $ unsafeCoerce# =<< HscMain.compileExpr hscEnv (srcLocSpan interactiveSrcLoc) ce

#if __GLASGOW_HASKELL__ >= 800
ce2b :: HscEnv -> CoreExpr -> IO UnlinkedBCO
ce2b HscEnv
hscEnv CoreExpr
pe = HscEnv -> Module -> CoreExpr -> IO UnlinkedBCO
coreExprToBCOs HscEnv
hscEnv Module
forall a. HasCallStack => a
undefined CoreExpr
pe
#else
# if __GLASGOW_HASKELL__ >= 700
ce2b hscEnv pe = coreExprToBCOs (hsc_dflags hscEnv) undefined pe
# else
ce2b hscEnv pe = coreExprToBCOs (hsc_dflags hscEnv) pe
# endif
#endif

runCoreExpr, runPrepedCoreExpr :: HscEnv -> CoreExpr -> IO a
runCoreExpr :: HscEnv -> CoreExpr -> IO a
runCoreExpr HscEnv
hscEnv CoreExpr
ce
    = -- repeatIO 10 $
      do
         let dfs :: DynFlags
dfs = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv
#if __GLASGOW_HASKELL__ >= 706
         CoreExpr
pe <- DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr DynFlags
dfs HscEnv
hscEnv CoreExpr
ce -- runPrepedCoreExprとの違いはこのcorePrepExprがあるかどうかだけ
#else
         pe <- corePrepExpr dfs ce -- runPrepedCoreExprとの違いはこのcorePrepExprがあるかどうかだけ
#endif
         UnlinkedBCO
bcos <- -- repeatIO 10 $
                 HscEnv -> CoreExpr -> IO UnlinkedBCO
ce2b HscEnv
hscEnv CoreExpr
pe
#ifdef PRELINK
         hv <- linkTheExpr bcos
#else
         ForeignHValue
hv <-HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
linkExpr HscEnv
hscEnv SrcSpan
noSrcSpan UnlinkedBCO
bcos
#endif
         a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ ForeignHValue -> a
unsafeCoerce# ForeignHValue
hv

runPrepedCoreExpr :: HscEnv -> CoreExpr -> IO a
runPrepedCoreExpr HscEnv
hscEnv CoreExpr
ce
    = -- repeatIO 10 $
      do
         UnlinkedBCO
bcos <- HscEnv -> CoreExpr -> IO UnlinkedBCO
ce2b HscEnv
hscEnv CoreExpr
ce
         -- repeatIO 10 $
#ifdef PRELINK
         hv <- linkTheExpr bcos
#else
         ForeignHValue
hv <-HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
linkExpr HscEnv
hscEnv SrcSpan
noSrcSpan UnlinkedBCO
bcos
#endif
         a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ ForeignHValue -> a
unsafeCoerce# ForeignHValue
hv

#ifdef PRELINK
-- | If already prelinked linkTheExpr can be used in place of linkExpr.
linkTheExpr :: UnlinkedBCO -> IO HValue
linkTheExpr ulbco
    = do pls <- readIORef v_PersistentLinkerState
         let ie = itbl_env pls
             ce = closure_env pls
             nm = unlinkedBCOName ulbco
         fixIO (\hv -> linkBCO ie (extendClosureEnv ce [(nm,hv)]) ulbco)
#endif

#if __GLASGOW_HASKELL__ >= 810
stmtToCore :: HscEnv -> GhciLStmt GhcPs -> IO (Maybe ([Id], CoreExpr))
#endif
-- The type of LStmt has changed during move to GHC 7.8.1.
-- stmtToCore :: HscEnv -> HsExpr.LStmt RdrName.RdrName -> IO (Maybe ([Id], CoreExpr))
stmtToCore :: HscEnv -> GhciLStmt GhcPs -> IO (Maybe ([Id], CoreExpr))
stmtToCore HscEnv
hscEnv GhciLStmt GhcPs
pst = do let dfs :: DynFlags
dfs  = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv
                               icxt :: InteractiveContext
icxt = HscEnv -> InteractiveContext
hsc_IC     HscEnv
hscEnv
#if __GLASGOW_HASKELL__ >= 708
                           (Messages
tcmsgs, Maybe ([Id], LHsExpr GhcTc, FixityEnv)
mbtc) <- HscEnv
-> GhciLStmt GhcPs
-> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
tcRnStmt HscEnv
hscEnv GhciLStmt GhcPs
pst
#else                
                           (tcmsgs, mbtc) <- tcRnStmt hscEnv icxt pst
#endif
                           case Maybe ([Id], LHsExpr GhcTc, FixityEnv)
mbtc of Maybe ([Id], LHsExpr GhcTc, FixityEnv)
Nothing             -> DynFlags -> Messages -> IO (Maybe ([Id], CoreExpr))
forall a. DynFlags -> Messages -> IO (Maybe a)
perror DynFlags
dfs Messages
tcmsgs
#if __GLASGOW_HASKELL__ >= 706
                                        Just ([Id]
ids, LHsExpr GhcTc
tc_expr, FixityEnv
_fixtyenv) -> do -- desugar
#else
                                        Just (ids, tc_expr) -> do -- desugar
#endif
#if __GLASGOW_HASKELL__ >= 708
                                          (Messages
desmsgs, Maybe CoreExpr
mbds) <- HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)
deSugarExpr HscEnv
hscEnv LHsExpr GhcTc
tc_expr
#else
# if __GLASGOW_HASKELL__ >= 700
                                          let typeEnv = mkTypeEnv (ic_tythings icxt)
# else
                                          let typeEnv = mkTypeEnv (map AnId (ic_tmp_ids icxt))
# endif
                                          (desmsgs, mbds) <- deSugarExpr hscEnv iNTERACTIVE (ic_rn_gbl_env icxt) typeEnv tc_expr
#endif
                                          case Maybe CoreExpr
mbds of Maybe CoreExpr
Nothing -> DynFlags -> Messages -> IO (Maybe ([Id], CoreExpr))
forall a. DynFlags -> Messages -> IO (Maybe a)
perror DynFlags
dfs Messages
desmsgs
                                                       Just CoreExpr
ds -> Maybe ([Id], CoreExpr) -> IO (Maybe ([Id], CoreExpr))
forall (m :: * -> *) a. Monad m => a -> m a
return (([Id], CoreExpr) -> Maybe ([Id], CoreExpr)
forall a. a -> Maybe a
Just ([Id]
ids, CoreExpr
ds))
#if __GLASGOW_HASKELL__ >= 706
perror :: DynFlags -> Messages -> IO (Maybe a)
perror DynFlags
dfs (Bag ErrMsg
wmsg,Bag ErrMsg
emsg) = DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors DynFlags
dfs Bag ErrMsg
wmsg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors DynFlags
dfs Bag ErrMsg
emsg IO () -> IO (Maybe a) -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
#else
# if __GLASGOW_HASKELL__ >= 700
perror dfs (wmsg,emsg) = let sdocs = pprErrMsgBag wmsg ++ pprErrMsgBag emsg in mapM_ (printError noSrcSpan) sdocs >> return Nothing
# else
perror dfs msg = printErrorsAndWarnings dfs msg >> return Nothing
# endif
#endif

#if __GLASGOW_HASKELL__ >= 810
thExpToStmt :: HscEnv -> TH.Exp -> GhciLStmt GhcPs
#endif
-- thExpToStmt :: HscEnv -> TH.Exp -> HsExpr.LStmt RdrName.RdrName
thExpToStmt :: HscEnv -> Exp -> GhciLStmt GhcPs
thExpToStmt HscEnv
hscEnv = LHsExpr GhcPs -> GhciLStmt GhcPs
forall a idL idR body.
(HasSrcSpan a, IdP idL ~ RdrName, XValBinds idL idR ~ NoExtField,
 XLetStmt idL idR body ~ NoExtField,
 XHsValBinds idL idR ~ NoExtField, XVarBind idL idR ~ NoExtField,
 SrcSpanLess a ~ StmtLR idL idR body) =>
LHsExpr idR -> a
wrapLHsExpr (LHsExpr GhcPs -> GhciLStmt GhcPs)
-> (Exp -> LHsExpr GhcPs) -> Exp -> GhciLStmt GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Exp -> LHsExpr GhcPs
thExpToLHsExpr HscEnv
hscEnv
-- #if __GLASGOW_HASKELL__ >= 810
-- wrapLHsExpr ::  HsExpr.LHsExpr GhcPs -> HsExpr.LStmt GhcPs _
-- #endif
-- wrapLHsExpr ::  HsExpr.LHsExpr RdrName.RdrName -> HsExpr.LStmt RdrName.RdrName
wrapLHsExpr :: LHsExpr idR -> a
wrapLHsExpr LHsExpr idR
expr =
  SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess a -> a) -> SrcSpanLess a -> a
forall a b. (a -> b) -> a -> b
$ XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt
#if __GLASGOW_HASKELL__ >= 806 && !defined GHCAPICOMPAT
  noExt $ noLoc $ HsValBinds noExt (ValBinds noExt (Bag.unitBag (HsUtils.mkHsVarBind noSrcSpan var expr)) [])
#else
# if __GLASGOW_HASKELL__ >= 800
#  if __GLASGOW_HASKELL__ >= 810
 NoExtField
XLetStmt idL idR body
noExtField (LHsLocalBindsLR idL idR -> StmtLR idL idR body)
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsLocalBindsLR idL idR -> LHsLocalBindsLR idL idR
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan (XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds NoExtField
XHsValBinds idL idR
noExtField (HsValBindsLR idL idR -> HsLocalBindsLR idL idR)
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
forall a b. (a -> b) -> a -> b
$ XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds NoExtField
XValBinds idL idR
noExtField (GenLocated SrcSpan (HsBindLR idL idR) -> LHsBindsLR idL idR
forall a. a -> Bag a
Bag.unitBag (SrcSpan
-> HsBindLR idL idR -> GenLocated SrcSpan (HsBindLR idL idR)
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan (HsBindLR idL idR -> GenLocated SrcSpan (HsBindLR idL idR))
-> HsBindLR idL idR -> GenLocated SrcSpan (HsBindLR idL idR)
forall a b. (a -> b) -> a -> b
$ XVarBind idL idR
-> IdP idL -> LHsExpr idR -> Bool -> HsBindLR idL idR
forall idL idR.
XVarBind idL idR
-> IdP idL -> LHsExpr idR -> Bool -> HsBindLR idL idR
VarBind NoExtField
XVarBind idL idR
noExtField IdP idL
RdrName
var LHsExpr idR
expr Bool
False)) [])
--  noExt $ noLoc $ HsValBinds (ValBinds noExtField (Bag.unitBag (HsUtils.mkHsVarBind noSrcSpan var expr)) [])
#  else
  $ noLoc $ HsValBinds (ValBindsIn (Bag.unitBag (HsUtils.mkHsVarBind noSrcSpan var expr)) [])
#  endif
# else
  $ HsValBinds (ValBindsIn (Bag.unitBag (HsUtils.mk_easy_FunBind noSrcSpan var [] expr)) [])
# endif
#endif
  where var :: RdrName
var = OccName -> RdrName
Unqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ NameSpace -> FilePath -> OccName
mkOccName NameSpace
OccName.varName FilePath
"__cmCompileExpr"

#if __GLASGOW_HASKELL__ >= 810
thExpToLHsExpr :: HscEnv -> TH.Exp -> HsExpr.LHsExpr GhcPs
thExpToLHsExpr :: HscEnv -> Exp -> LHsExpr GhcPs
thExpToLHsExpr HscEnv
hscEnv Exp
e = case Origin -> SrcSpan -> Exp -> Either MsgDoc (LHsExpr GhcPs)
GHC.ThToHs.convertToHsExpr Origin
BasicTypes.Generated SrcSpan
noSrcSpan Exp
e of
                    Left  MsgDoc
msg -> FilePath -> LHsExpr GhcPs
forall a. HasCallStack => FilePath -> a
error (FilePath -> LHsExpr GhcPs) -> FilePath -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> FilePath
showSDoc (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv) MsgDoc
msg
                    Right LHsExpr GhcPs
expr -> LHsExpr GhcPs
expr
#else
-- thExpToLHsExpr :: HscEnv -> TH.Exp -> HsExpr.LHsExpr RdrName.RdrName -- for old versions of GHC API
-- thExpToLHsExpr :: HscEnv -> TH.Exp -> HsExpr.LHsExpr GhcPs           -- for new versions of GHC API
thExpToLHsExpr hscEnv e = case Convert.convertToHsExpr noSrcSpan e of
# if __GLASGOW_HASKELL__ >= 706
                    Left  msg -> error $ showSDoc (hsc_dflags hscEnv) msg
# else
                    Left  msg -> error $ showSDoc msg
# endif
                    Right expr -> expr
#endif

-- unused, but may be useful in future
#if __GLASGOW_HASKELL__ < 706
instance Show b => Show (Expr b) where
    showsPrec p (Var var) = ("Var "++) . (showSDocDebug (ppr var) ++)
    showsPrec _ (Lit l)   = ("Lit "++) . shows l
    showsPrec _ (App e0@(App _ _) e1) = shows e0 . (" `App` "++) . showParen True (shows e1)
    showsPrec _ (App e0 e1)           = showParen True (shows e0) . (" `App` "++) . showParen True (shows e1)
    showsPrec _ (Lam v e)             = ('\\':) . shows v . shows e
    showsPrec _ (Let bs e)            = ("let"++) . shows bs . (" in "++) . shows e
    showsPrec _ (Case _ _ _ _) = ("case"++)
    showsPrec _ (Cast e t)     = ("Cast "++) . showParen True (shows e) . ("<Coercion>"++)
--    showsPrec _ (Note _ _)     = ("Note"++)
    showsPrec _ (Type t)       = (showSDoc (pprType t) ++)
instance Show b => Show (Bind b) where
    showsPrec _ (NonRec b e) = (' ':) . shows b . (" = "++) . shows e
    showsPrec _ (Rec ts )    = ("rec { "++) . foldr (.) id (map hoge ts) . (" } "++)
hoge :: Show b => (b, Expr b) -> ShowS
hoge (b, e) = shows b . (" = "++) . shows e . (" ; "++)
#endif

{- unused. also, anyPrimTy does not appear in ghc-7.* any longer
-- remove the type info to see if they are necessary even when there is no ad-hoc polymorphism
removeTInfo :: Expr b -> Expr b
removeTInfo (App e0 e1) = App (removeTInfo e0) (removeTInfo e1)
removeTInfo (Lam v e)   = Lam v (removeTInfo e)
removeTInfo (Let bs e)  = Let (rtis bs) (removeTInfo e)
removeTInfo (Type t)    = Type anyPrimTy
removeTInfo (Cast e t)  = Cast (removeTInfo e) t
removeTInfo e           = e

rtis (NonRec b e) = NonRec b (removeTInfo e)
rtis (Rec    ts)  = Rec [ (b, removeTInfo e) | (b,e) <- ts ]
-}

compileExprHscMain :: HscEnv -> CoreExpr -> IO HValue
compileExprHscMain :: HscEnv -> CoreExpr -> IO HValue
compileExprHscMain HscEnv
hscEnv CoreExpr
ce
  =  do let dflags :: DynFlags
dflags  = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv
        CoreExpr
smpl <- DynFlags -> CoreExpr -> IO CoreExpr
simplifyExpr   DynFlags
dflags CoreExpr
ce
#if __GLASGOW_HASKELL__ >= 706
        CoreExpr
prep <- DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr DynFlags
dflags HscEnv
hscEnv CoreExpr
smpl
#else
        prep <- corePrepExpr   dflags smpl
#endif
        UnlinkedBCO
bcos <- HscEnv -> CoreExpr -> IO UnlinkedBCO
ce2b HscEnv
hscEnv CoreExpr
prep
        HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
linkExpr HscEnv
hscEnv SrcSpan
noSrcSpan UnlinkedBCO
bcos
#if __GLASGOW_HASKELL__ >= 800
            IO ForeignHValue -> (ForeignHValue -> IO HValue) -> IO HValue
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynFlags -> ForeignHValue -> IO HValue
forall a. DynFlags -> ForeignRef a -> IO a
wormhole DynFlags
dflags
#endif


#ifdef GHC6
{-
directLoadObj :: [String] -- ^ visible modules (including package modules). You may omit the Prelude.
           -> [(a, TH.Exp, TH.Type)]
           -> IO (CoreLang.CoreExpr -> Dynamic)
directLoadObj fss tups
    = defaultErrorHandler defaultDynFlags $ do
        hscEnv <- prepareAPI [] fss

#ifdef PRELINK
        hPutStrLn stderr "prelink! (temporarily)"
        compileExpr hscEnv "([], (:), list_para)"
--        compileExpr session "([]::[a], (:)::a->[a]->[a], list_para::[b]->a->(b->[b]->a->a)->a)"
--          compileExpr "([]::[Char], (:)::Char->[Char]->[Char], list_para::[Char]->Int->
#endif

        gm <- mkGlobalAr hscEnv tups
        return $ unsafeDirectExecuteAPI hscEnv gm
-}
unsafeDirectExecuteAPI hscEnv gm ce = unsafePerformIO $ directExecuteAPI hscEnv gm ce
directExecuteAPI :: HscEnv -> GlobalAr -> CoreLang.CoreExpr -> IO a
directExecuteAPI hscEnv gm ce
    = runCoreExpr hscEnv $ ceToCSCE gm ce


-- Note: MagicHaskeller.Primitive = (HValue, TH.Exp, TH.Type)
-- Use
--  typeToTHType :: TyConLib -> Types.Type -> TH.Type
-- if necessary. TyConLib can be undefined here.
compileVar :: HscEnv -> (a, TH.Exp, TH.Type) -> IO CoreSyn.CoreExpr
compileVar hscEnv (_, the, ty)
    = do csce <- compileCoreExpr hscEnv the -- これだと，[| (==)::Char->Char->Bool |]みたいな場合にtheが単にVarE '(==)になってうまくいかない．(ad hocなtyvarがinstantiateされない)
         -- Just (_,csce) <- strToCore session ("let __compileExpr = ("++TH.pprint the ++")::"++TH.pprint (unforall ty))
         let unr = unwrap csce
         putStrLn ("csce = "++show unr)
         case ty of TH.ForallT tvs [] _ -> do let dfs = hsc_dflags hscEnv
                                              simplifyExpr dfs $ foldl CoreSyn.App unr $ replicate (length tvs) $ CoreSyn.Type anyPrimTy
                                              -- CorePrep は 不要なはずではあるが，どうするよ？
                    _                   -> return unr
unwrap (Let (Rec ((_,e):_)) _) = e
-- unwrap (Let (Rec [(_,e)]) _) = e -- こっちだとなぜかダメで，その辺にバグのにほひが....
unwrap st                    = error (show st)
unforall (TH.ForallT _ _ t) = t
unforall t = t

type GlobalMap = Map.Map String CoreSyn.CoreExpr -- Stringの代わりにTH.Nameなどにしようとすると，ちゃんとequivalenceが思い通りの結果になってくれない．．
mkGlobalMap :: HscEnv -> [(a, TH.Exp, TH.Type)] -> IO GlobalMap
-- てゆーか，CoreLang.CoreExprのPrimitiveがCoreSyn.CoreExprの情報を持つのが速い．
-- data CoreExpr a = ... みたいにして，CoreExpr CoreSyn.CoreExprみたいに使う．
mkGlobalMap hscEnv tups =  do ces <- mapM (compileVar hscEnv) tups
                              return $ Map.fromList $ zip (map (\(_,b,_) -> thToBaseString b) tups) ces


{-
-- See Linker.linkDependencies
linkDeps :: Session -> [Module] -> IO Bool
linkDeps session mods = 

てゆーか最初に"([],(:),list_para,lines,take)"みたいなのをcompileExprしてしまえばprelinkされるのでは？


-- obtain the set of modules required to be linked
cscesToNeededModules :: [CoreSyn.CoreExpr] -> [Module]
cscesToNeededModules csces = [ GHC.nameModule n | csce <- csces,
                                                  var  <- csceToVars' csce [],
                                                  let n = Var.varName n,
                                                  isExternalName n,
                                                  not (isWiredInName n) ]

-- Should I define instance Generic (Expr b)?
csceToVars' :: CoreSyn.CoreExpr -> [Var.Var] -> [Var.Var]
csceToVars' (Var var)   = (var:)
csceToVars' (App e0 e1) = csceToVars' e0 . csceToVars' e1
csceToVars' (Lam _ e)   = csceToVars' e
csceToVars' (Let (NonRec _ e0) e1) = csceToVars' e0 . csceToVars' e1
csceToVars' (Let (Rec tups) e)     = foldr (.) (csceToVars' e) [ csceToVars' a | (_,a) <- tups ]
csceToVars' (Case e _ _ tups)      = foldr (.) (csceToVars' e) [ csceToVars' a | (_,_,a) <- tups ]
csceToVars' (Cast e _)             = csceToVars' e
csceToVars' (Note _ e)             = csceToVars' e
csceToVars' _                      = id -- Lit case and Type case

-}


thExpToCSCE :: GlobalMap -> TH.Exp -> CoreSyn.CoreExpr
thExpToCSCE gm ce = ctc [] ce
    where ctc pvs (TH.LamE pvars e)       = foldr CoreSyn.Lam (ctc (pvars++pvs) e) (map (mkStrVar . show . unVarP) pvars)
          ctc pvs (e0 `TH.AppE` e1)       = ctc pvs e0 `CoreSyn.App` ctc pvs e1
          ctc pvs (InfixE (Just e0) e (Just e1)) = lup e `CoreSyn.App` ctc pvs e0 `CoreSyn.App` ctc pvs e1 
          ctc pvs (TH.VarE name) | VarP name `elem` pvs = CoreSyn.Var $ mkStrVar $ show name
          -- VarEの場合，lambda boundの場合と，globalの場合とで扱いが異なる．
          -- スコープをまじめに考えると，lambda boundかどうかをチェックしてからglobalにあるかどうかをみることになる． 
          ctc pvs e                       = lup e
          lup e = case Map.lookup (thToBaseString e) gm of Nothing   -> error (show e ++ ", i.e.,\n" ++ TH.pprint e ++ " : could not convert to CoreSyn.CoreExpr")
                                                           Just csce -> csce
thToBaseString (ConE name) = nameBase name
thToBaseString (VarE name) = nameBase name

unVarP (TH.VarP n) = n
mkIntVar i   = Id.mkUserLocal (mkVarOcc [chr i]) (Unique.getUnique i) anyPrimTy noSrcSpan
mkStrVar str = Id.mkUserLocal (mkVarOcc str) (Unique.getUnique $ mkFastString str) anyPrimTy noSrcSpan


type GlobalAr = Array Int CoreSyn.CoreExpr
mkGlobalAr :: HscEnv -> [(a, TH.Exp, TH.Type)] -> IO GlobalAr
mkGlobalAr hscEnv tups = do ces <- mapM (compileVar hscEnv) tups
                            return $ listArray (0, length tups - 1) ces

ceToCSCE :: GlobalAr -> CoreLang.CoreExpr -> CoreSyn.CoreExpr
ceToCSCE ga ce = ctc (ord 'a'-1) ce
    where ctc dep (CoreLang.Lambda e)       = CoreSyn.Lam  (mkIntVar (dep+1)) $ ctc (dep+1) e
          ctc dep (CoreLang.X n)            = CoreSyn.Var $ mkIntVar (dep-n)
          ctc dep (CoreLang.Primitive n _)    = ga ! n
          ctc dep (e0 CoreLang.:$ e1)       = ctc dep e0 `CoreSyn.App` ctc dep e1




es = map mkIntVar [ord 'e'..]
as = map mkIntVar [128..] -- 無理がある?
xs = map mkIntVar [192..]
hd = mkIntVar (ord 'a')   -- これは引数にしても良い

mkTV :: Int -> Types.Type
mkTV = Types.TV
tvrs = map mkTV [1..]
tvas = map mkTV [2000..]
tvr  = mkTV 0

-- ({} \ hd e1..em a1..an -> {hd e1..em a1..an} let x1 = {e1 a1..an} e1 a1..an in {hd x1 e2..em a1..an} let x2 = {e2 a1..an} e2 a1..an in .. {hd x1..xm-1 em a1..an} let xm = {em a1..an} em a1..an in {hd x1..xm} hd x1..xm
-- てか，一番上がemptyVarSetであることを除けば，あとはundefinedでいいはず．... と思ったけど，schemeEの定義を見た感じlet bindingsの右辺の一番外側に関しては必要みたい．see notes on Aug. 12, 2008
-- ({} \ hd e1..em a1..an -> let x1 = {e1 a1..an} e1 a1..an in let x2 = {e2 a1..an} e2 a1..an in .. let xm = {em a1..an} em a1..an in hd x1..xm
-- という程度の情報があれば十分．

-- (\hd e1..em a1..an -> let x1 = e1 a1..an in .. let xm = em a1..an in hd x1..xm) :: (r1->..->rm->r) -> (a1->..->an->r1)->..->(a1->..->an->rm) -> a1->..->an -> r
hdmnPreped :: Int -> Int -> CoreSyn.CoreExpr
hdmnPreped m 0 = hdmn m 0 -- 要はidを生成するってこと．
hdmnPreped m n = lambdas $ lets $ foldl CoreSyn.App (CoreSyn.Var hd) (map CoreSyn.Var mxs)
    where
       mes = take m es
       mxs = take m xs
       nas = take n as
       lambdas = flip (foldr ($)) (map CoreSyn.Lam (hd : mes ++ nas))
       lets = flip (foldr CoreSyn.Let) binds 
           where binds = zipWith CoreSyn.NonRec mxs $ map appa1an mes
                     where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas
-- CorePrep 前のものを生成する場合
-- (\hd e1..em a1..an -> hd (e1 a1..an) .. (em a1..an)) :: (r1->..->rm->r) -> (a1->..->an->r1)->..->(a1->..->an->rm) -> a1->..->an -> r
hdmn m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var hd) $ map appa1an mes
 where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas
       mes = take m es
       nas = take n as
       lambdas = flip (foldr ($)) (map CoreSyn.Lam (hd : mes ++ nas))

hdmnty :: Int -> Int -> Types.Type
hdmnty m n = hdty Types.:-> foldr (Types.:->) (foldr (Types.:->) tvr nas) (map (\r -> foldr (Types.:->) r nas) mrs)
    where hdty = foldr (Types.:->) tvr mrs
          mrs  = take m tvrs
          nas  = take n tvas


-- (\e1..em a1..an -> let x1 = e1 a1..an in .. let xm = em a1..an in ai x1 .. xm) -- more exactly, not ai but ai-1 because (!!) counts starting 0
--   :: (a1->..->(r1->..->rm->r)->..->an->r1)->..->(a1->..->(r1->..->rm->r)->..->an->rm) ->
--       a1->..->(r1->..->rm->r)->..->an -> r
-- aimnPreped i m 0 = aimn i m 0 -- これはありえないケース
aimnPreped i m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var (as!!i)) (map CoreSyn.Var mxs)
 where mes = take m es
       mxs = take m xs
       nas = take n as
       lambdas = flip (foldr ($)) (map CoreSyn.Lam (mes ++ nas))
       lets = flip (foldr CoreSyn.Let) binds 
           where binds = zipWith CoreSyn.NonRec mxs $ map appa1an mes
                     where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas
-- CorePrep前のものを生成する場合
-- (\e1..em a1..an -> ai (e1 a1..an) .. (em a1..an)) -- more exactly, not ai but ai-1 because (!!) counts starting 0
--   :: (a1->..->(r1->..->rm->r)->..->an->r1)->..->(a1->..->(r1->..->rm->r)->..->an->rm) ->
--       a1->..->(r1->..->rm->r)->..->an -> r
aimn i m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var (as!!i)) $ map appa1an mes
 where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas
       mes = take m es
       nas = take n as
       lambdas = flip (foldr ($)) (map CoreSyn.Lam (mes ++ nas))

aimnty :: Int -> Int -> Int -> Types.Type
aimnty i m n = foldr (Types.:->) (foldr (Types.:->) tvr nas) (map (\r -> foldr (Types.:->) r nas) mrs)
    where hdty = foldr (Types.:->) tvr mrs
          mrs  = take m tvrs
          nas  = case splitAt i tvas of (tk,_:dr) -> tk ++ hdty : take (n-i-1) dr -- hdmntyとの違いはここだけ

mkHdmn :: HscEnv -> Int -> Int -> IO Dynamic
mkHdmn hscEnv m n =  do let ce = hdmn m n
                        val <- runCoreExpr hscEnv ce
                        return $ unsafeToDyn undefined (hdmnty m n) val undefined -- (CoreLang.exprToTHExp undefined ce) CoreLangではなくてCoreSynから
mkAimn :: HscEnv -> Int -> Int -> Int -> IO Dynamic
mkAimn hscEnv i m n =  do let ce = aimn i m n
                          val <- runCoreExpr hscEnv ce
                          return $ unsafeToDyn undefined (aimnty i m n) val undefined -- (CoreLang.exprToTHExp undefined ce)
#endif
-- ifdef GHC6

-- こっからプロファイル用


repeatN :: Int -> (Any -> Any) -> Any -> Any
repeatN  Int
n Any -> Any
f Any
x = [Any] -> Any
forall a. [a] -> a
force ([Any] -> Any) -> [Any] -> Any
forall a b. (a -> b) -> a -> b
$ (Any -> Any) -> [Any] -> [Any]
forall a b. (a -> b) -> [a] -> [b]
map Any -> Any
f ([Any] -> [Any]) -> [Any] -> [Any]
forall a b. (a -> b) -> a -> b
$ Int -> Any -> [Any]
forall a. Int -> a -> [a]
replicate Int
n Any
x
repeatIO :: Int -> IO a -> IO a
repeatIO :: Int -> IO a -> IO a
repeatIO Int
n IO a
act = ([a] -> a) -> IO [a] -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> a
forall a. [a] -> a
force (IO [a] -> IO a) -> IO [a] -> IO a
forall a b. (a -> b) -> a -> b
$ [IO a] -> IO [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO a] -> IO [a]) -> [IO a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ Int -> IO a -> [IO a]
forall a. Int -> a -> [a]
replicate Int
n IO a
act

-- force (x:xs) = all (x==) xs `seq` x
force :: [a] -> a
force = (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 a -> a -> a
seq

instance Eq (Expr a) where
    Var Id
i == :: Expr a -> Expr a -> Bool
== Var Id
j = Bool
True -- i==j
    Lit Literal
l == Lit Literal
m = Literal
lLiteral -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
==Literal
m
    App Expr a
f Expr a
e == App Expr a
g Expr a
i = Expr a
gExpr a -> Expr a -> Bool
forall a. Eq a => a -> a -> Bool
==Expr a
f Bool -> Bool -> Bool
&& Expr a
eExpr a -> Expr a -> Bool
forall a. Eq a => a -> a -> Bool
==Expr a
i
    Lam a
b Expr a
e == Lam a
c Expr a
f = {- b==c && -} Expr a
eExpr a -> Expr a -> Bool
forall a. Eq a => a -> a -> Bool
==Expr a
f
    Let Bind a
b Expr a
e == Let Bind a
c Expr a
f = {- b==c && -} Expr a
eExpr a -> Expr a -> Bool
forall a. Eq a => a -> a -> Bool
==Expr a
f
    Case Expr a
e a
b Type
t [Alt a]
ab == Case Expr a
f a
c Type
u [Alt a]
bc = Expr a
eExpr a -> Expr a -> Bool
forall a. Eq a => a -> a -> Bool
==Expr a
f {- && b==c && t==u && ab == bc -}
    Cast Expr a
e Coercion
c      == Cast Expr a
f Coercion
d = Expr a
eExpr a -> Expr a -> Bool
forall a. Eq a => a -> a -> Bool
==Expr a
f {- && c==d -}
--    Note n e == Note m f = {- n==m && -} e==f
    Type Type
t == Type Type
u = Bool
True -- t==u