85 lines
2.4 KiB
Haskell
85 lines
2.4 KiB
Haskell
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE OrPatterns #-}
|
|
module Main
|
|
(main)
|
|
where
|
|
|
|
import Gyehoek.Options
|
|
import qualified Data.Text.IO as TIO
|
|
import Data.Text (Text)
|
|
import Prelude hiding (readFile)
|
|
import Options.Applicative
|
|
import Control.Lens
|
|
import Data.Generics.Labels
|
|
import System.OsPath (OsPath)
|
|
import System.FilePath ((-<.>), dropExtension)
|
|
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, gensym, gensym')
|
|
import qualified Gyehoek.Sexp as Sexp
|
|
import Data.Text.Lens
|
|
import Data.List (List)
|
|
import qualified Gyehoek.Scheme.Syntax as Scm
|
|
import Effectful.Exception
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as T
|
|
import System.IO (Handle)
|
|
import Data.List.NonEmpty (NonEmpty)
|
|
import qualified Cradle as C
|
|
import Gyehoek.CPS.Convert
|
|
import Gyehoek.CPS.Lower
|
|
import Data.Foldable
|
|
import qualified Gyehoek.Scheme.Syntax
|
|
import Gyehoek.CPS.Syntax
|
|
import Data.Maybe (fromMaybe)
|
|
|
|
|
|
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
|
|
|
|
readScm :: FileSystem :> es => FilePath -> Eff es Scm.Exp
|
|
readScm f =
|
|
withFile f FS.ReadMode $ \h ->
|
|
Sexp.parseSexps f <$> hGetContents h
|
|
>>= either error wrap
|
|
where
|
|
wrap [x] = pure x
|
|
wrap xs = pure . Gyehoek.Scheme.Syntax.ExpBegin $ xs
|
|
|
|
driver
|
|
:: (GenSym :> es, FileSystem :> es, IOE :> es)
|
|
=> Options -> Eff es ()
|
|
driver opts = do
|
|
scm <- readScm opts.sourceFile
|
|
cps <- convert scm (pure . Halt1)
|
|
wat <- lower cps
|
|
withFile opts.output FS.WriteMode \h ->
|
|
hPutStr h wat
|