140 lines
4.5 KiB
Haskell
140 lines
4.5 KiB
Haskell
module Gyehoek.Driver
|
|
(main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
|
|
where
|
|
|
|
import Gyehoek.Options
|
|
import Data.Text (Text)
|
|
import Prelude hiding (readFile)
|
|
import Options.Applicative
|
|
import Control.Lens
|
|
import Effectful.FileSystem
|
|
import Effectful
|
|
import Effectful.FileSystem.IO qualified as FS
|
|
import Effectful.FileSystem.IO.ByteString qualified as FB
|
|
import Gyehoek.GenSym (runGenSym, GenSym)
|
|
import qualified Gyehoek.Sexp as Sexp
|
|
import qualified Gyehoek.Scheme.Syntax as Scm
|
|
import qualified Data.Text.Encoding as T
|
|
import System.IO (Handle)
|
|
import System.IO qualified as IO
|
|
import Gyehoek.CPS.Convert
|
|
import Gyehoek.CPS.Lower
|
|
import Gyehoek.CPS.Syntax qualified as Cps
|
|
import Control.Monad
|
|
import Text.Pretty.Simple (pShowNoColor)
|
|
import System.Process.Typed
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import System.Environment.Blank (getEnvDefault)
|
|
import GHC.Conc (atomically)
|
|
import qualified Data.Text.IO as TIO
|
|
import qualified Data.ByteString.Lazy as BS
|
|
import Gyehoek.CPS.Stackify (stackifyProgram)
|
|
import Text.Pretty.Simple (pShow)
|
|
import Gyehoek.Stack.VM (eval, writeObj, Obj)
|
|
import qualified Data.Text as T
|
|
import Data.List (List)
|
|
import Gyehoek.Stack.Syntax (encodeProgram)
|
|
import Effectful.Exception
|
|
|
|
|
|
main :: IO ()
|
|
main = do
|
|
opts <- execParser $ info (helper <*> parser) fullDesc
|
|
runEff . runFileSystem . runGenSym . driver $ opts
|
|
|
|
|
|
|
|
-- hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
|
|
-- hPutStr h = FB.hPutStr h . T.encodeUtf8
|
|
|
|
hPutStrLn :: FileSystem :> es => Handle -> Text -> Eff es ()
|
|
hPutStrLn h = FB.hPutStrLn h . T.encodeUtf8
|
|
|
|
hGetContents :: FileSystem :> es => Handle -> Eff es Text
|
|
hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
|
|
|
|
-- readFile :: FileSystem :> es => FilePath -> Eff es Text
|
|
-- readFile f = FS.withFile f FS.ReadMode hGetContents
|
|
|
|
withFile
|
|
:: (FileSystem :> es)
|
|
=> FilePath -> FS.IOMode -> (Handle -> Eff es a) -> Eff es a
|
|
withFile "-" FS.ReadMode k = k FS.stdin
|
|
withFile "-" (FS.WriteMode; FS.AppendMode) k = k FS.stdout
|
|
withFile f m k = FS.withFile f m k
|
|
|
|
fileName :: FilePath -> FilePath
|
|
fileName "-" = "<interactive>"
|
|
fileName e = e
|
|
|
|
readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program
|
|
readScm f =
|
|
withFile f FS.ReadMode $ \h ->
|
|
Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h
|
|
>>= either error (pure . Scm.MkProgram)
|
|
|
|
inspectWasm :: IOE :> es => Text -> Eff es ()
|
|
inspectWasm wat = do
|
|
pager_cmd <- liftIO $ getEnvDefault "PAGER" "less"
|
|
let wasmtools_cfg
|
|
= proc "wasm-tools" ["print", "-pf", "--print-operand-stack"
|
|
,"--color", "always", "-"]
|
|
-- & setStdin (byteStringInput . view lazy . encodeUtf8 $ wat)
|
|
-- & setStdout byteStringOutput
|
|
& setStdin createPipe
|
|
& setStdout createPipe
|
|
& setStderr inherit
|
|
let pager_cfg = proc pager_cmd []
|
|
& setStdin createPipe
|
|
& setStdout inherit
|
|
& setStderr inherit
|
|
liftIO $ withProcessWait_ wasmtools_cfg \wasmtools -> do
|
|
TIO.hPutStrLn (getStdin wasmtools) wat
|
|
IO.hFlush (getStdin wasmtools)
|
|
IO.hClose (getStdin wasmtools)
|
|
withProcessWait_ pager_cfg \pager -> do
|
|
t <- BS.hGetContents (getStdout wasmtools)
|
|
BS.hPut (getStdin pager) t
|
|
IO.hFlush (getStdin pager)
|
|
IO.hClose (getStdin pager)
|
|
|
|
driver
|
|
:: (GenSym :> es, FileSystem :> es, IOE :> es)
|
|
=> Options -> Eff es ()
|
|
driver opts = do
|
|
scm <- readScm opts.sourceFile
|
|
when opts.dumpParsed do
|
|
hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
|
|
cps <- convertProgram scm
|
|
when opts.dumpCPS do
|
|
hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
|
|
stk <- stackifyProgram cps
|
|
if opts.dumpStackified then do
|
|
hPutStrLn FS.stdout . encodeProgram $ stk
|
|
else if opts.stackify then do
|
|
eval stk & fmap writeObj
|
|
& T.unwords
|
|
& hPutStrLn FS.stdout
|
|
else do
|
|
wat <- lowerProgram cps
|
|
withFile opts.output FS.WriteMode \h ->
|
|
hPutStrLn h wat
|
|
when opts.inspectWasm do
|
|
inspectWasm wat
|
|
|
|
parse_e2e :: FilePath -> IO Scm.Program
|
|
parse_e2e = runEff . runFileSystem . readScm
|
|
|
|
convert_e2e :: FilePath -> IO Cps.Program
|
|
convert_e2e = runEff . runFileSystem . runGenSym . (convertProgram <=< readScm)
|
|
|
|
lower_e2e :: FilePath -> IO Text
|
|
lower_e2e =
|
|
runEff . runFileSystem . runGenSym
|
|
. (lowerProgram <=< convertProgram <=< readScm)
|
|
|
|
eval_e2e :: FilePath -> IO (List Obj)
|
|
eval_e2e fp = runEff . runFileSystem . runGenSym $ do
|
|
stk <- stackifyProgram <=< convertProgram <=< readScm $ fp
|
|
pure . eval $ stk
|