diff --git a/app/Main.hs b/app/Main.hs index 869aca6..559ef2b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,84 +1,6 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OrPatterns #-} -module Main - (main) - where +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) +import Gyehoek.Driver qualified -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 +main = Gyehoek.Driver.main diff --git a/cabal.project b/cabal.project index ebc155e..b50cb5f 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,5 @@ packages: *.cabal +tests: True source-repository-package type: git diff --git a/flake.nix b/flake.nix index 18a1fff..939fda5 100644 --- a/flake.nix +++ b/flake.nix @@ -30,10 +30,9 @@ haskell-language-server = {}; }; buildInputs = with final; [ - gcc - qbe haskellPackages.cabal-fmt self.packages.${final.stdenv.hostPlatform.system}.shake + final.haskellPackages.shelltestrunner final.wabt final.nodejs final.wasmtime diff --git a/golden/arith/exec b/golden/arith/exec new file mode 100644 index 0000000..0e2d2b5 --- /dev/null +++ b/golden/arith/exec @@ -0,0 +1,5 @@ +ret > ExitSuccess +out > 22 +out > +err > warning: using `--invoke` with a function that returns values is experimental and may break in the future +err > diff --git a/t.wat b/golden/arith/out.wat similarity index 88% rename from t.wat rename to golden/arith/out.wat index 8400043..3ec9052 100644 --- a/t.wat +++ b/golden/arith/out.wat @@ -1,5 +1,7 @@ (module - (func (param) (result i32) + (func + (param) + (result i32) (local i32 i32 i32 i32 i32) (i32.const 3) (i32.const 4) diff --git a/example/arith.scm b/golden/arith/source.scm similarity index 100% rename from example/arith.scm rename to golden/arith/source.scm diff --git a/golden/if-false/exec b/golden/if-false/exec new file mode 100644 index 0000000..1b2edc3 --- /dev/null +++ b/golden/if-false/exec @@ -0,0 +1,5 @@ +ret > ExitSuccess +out > 555 +out > +err > warning: using `--invoke` with a function that returns values is experimental and may break in the future +err > diff --git a/golden/if-false/out.wat b/golden/if-false/out.wat new file mode 100644 index 0000000..7dee941 --- /dev/null +++ b/golden/if-false/out.wat @@ -0,0 +1,11 @@ +(module + (func + (param) + (result i32) + (local i32 i32 i32 i32 i32) + (i32.const 0) + (if + (result i32) + (then (i32.const 777)) + (else (i32.const 555)))) + (export "main" (func 0))) \ No newline at end of file diff --git a/golden/if-false/source.scm b/golden/if-false/source.scm new file mode 100644 index 0000000..dd3eaff --- /dev/null +++ b/golden/if-false/source.scm @@ -0,0 +1 @@ +(if #false 777 555) diff --git a/golden/if-true/exec b/golden/if-true/exec new file mode 100644 index 0000000..d8d9f0f --- /dev/null +++ b/golden/if-true/exec @@ -0,0 +1,5 @@ +ret > ExitSuccess +out > 777 +out > +err > warning: using `--invoke` with a function that returns values is experimental and may break in the future +err > diff --git a/golden/if-true/out.wat b/golden/if-true/out.wat new file mode 100644 index 0000000..5fcebbe --- /dev/null +++ b/golden/if-true/out.wat @@ -0,0 +1,11 @@ +(module + (func + (param) + (result i32) + (local i32 i32 i32 i32 i32) + (i32.const 1) + (if + (result i32) + (then (i32.const 777)) + (else (i32.const 555)))) + (export "main" (func 0))) \ No newline at end of file diff --git a/golden/if-true/source.scm b/golden/if-true/source.scm new file mode 100644 index 0000000..2db74f9 --- /dev/null +++ b/golden/if-true/source.scm @@ -0,0 +1 @@ +(if #true 777 555) diff --git a/golden/square/source.scm b/golden/square/source.scm new file mode 100644 index 0000000..09f27cf --- /dev/null +++ b/golden/square/source.scm @@ -0,0 +1 @@ +((λ (x) (* x x)) 5) diff --git a/gyehoek.cabal b/gyehoek.cabal index e85866b..4c780e6 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -20,7 +20,7 @@ common ghcstuffs-dev common ghcstuffs ghc-options: -Wall -fdefer-type-errors -fno-show-valid-hole-fits - -fdefer-out-of-scope-variables -fplugin=Effectful.Plugin -threaded + -fdefer-out-of-scope-variables -threaded default-extensions: BlockArguments @@ -35,8 +35,19 @@ executable gyehoek import: ghcstuffs, ghcstuffs-dev main-is: Main.hs - -- cabal-fmt: expand app -Main - other-modules: + build-depends: + , base ^>=4.21.2.0 + , gyehoek + + hs-source-dirs: app + default-language: GHC2024 + +library + import: ghcstuffs, ghcstuffs-dev + ghc-options: -fplugin=Effectful.Plugin + + -- cabal-fmt: expand src + exposed-modules: Gyehoek.CPS.Convert Gyehoek.CPS.Lower Gyehoek.CPS.Syntax @@ -45,6 +56,7 @@ executable gyehoek Gyehoek.Scheme.Syntax Gyehoek.Sexp Gyehoek.Wasm + Gyehoek.Driver build-depends: , base ^>=4.21.2.0 @@ -72,6 +84,20 @@ executable gyehoek , unordered-containers , vector , string-interpolate + , pretty-simple - hs-source-dirs: app + hs-source-dirs: src default-language: GHC2024 + +test-suite test + import: ghcstuffs, ghcstuffs-dev + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base + , gyehoek + , filepath + , tasty + , tasty-silver + , directory + default-language: GHC2024 diff --git a/app/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs similarity index 64% rename from app/Gyehoek/CPS/Convert.hs rename to src/Gyehoek/CPS/Convert.hs index c8a32e3..24d93bd 100644 --- a/app/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedLists #-} module Gyehoek.CPS.Convert ( convert + , convertProgram ) where import Gyehoek.CPS.Syntax @@ -9,6 +10,8 @@ import Gyehoek.GenSym import Data.List.NonEmpty (NonEmpty((:|))) import Effectful import Control.Monad.Cont qualified as Cont +import Control.Lens +import qualified Data.List.NonEmpty as NE -- 뻘짓이어라 @@ -31,11 +34,11 @@ convert (Scm.ExpPrim p) k = ExpPrim p' [r] <$> k (ValVar r) convert (Scm.ExpLambda xs e) k = do - f <- gensym' "f" - ktail <- gensym' "ktail" + f <- gensym' "λ-body" + ktail <- gensym' "λ-tail" m <- convert e $ \e' -> - pure $ ExpApply (ValVar ktail) [e'] - ExpFix [(f, MkKappa (xs ++ [ktail]) m)] <$> k (ValVar f) + pure $ ExpContinue ktail [e'] + ExpLet [(f, MkLambda xs ktail m)] <$> k (ValVar f) convert (Scm.ExpApply f xs) k = telescope (convert @es) (f:|xs) \(f':|xs') -> do @@ -46,4 +49,15 @@ convert (Scm.ExpApply f xs) k = convert (Scm.ExpBegin xs) k = _ +convert (Scm.ExpIf c t f) k = + convert c \c' -> + ExpIf c' <$> convert t k <*> convert f k + convert _ k = _ + +convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program +convertProgram p = + MkProgram <$> telescope (convert @es) (p ^.. each . _Left) \exps -> + pure . Halt1 $ case NE.nonEmpty exps of + Nothing -> ValLit Void + Just es -> NE.last es diff --git a/app/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs similarity index 77% rename from app/Gyehoek/CPS/Lower.hs rename to src/Gyehoek/CPS/Lower.hs index 530f9fd..bd122a0 100644 --- a/app/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -7,7 +7,7 @@ {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Gyehoek.CPS.Lower ( - lower) where + lower, lowerProgram) where import Gyehoek.CPS.Syntax import Data.Generics.Labels @@ -24,7 +24,7 @@ import Data.Foldable import Data.HashMap.Strict (HashMap) import Numeric.Natural import GHC.Generics (Generic) -import Gyehoek.Scheme.Syntax (Lit(LitInt)) +import Gyehoek.Scheme.Syntax (Lit(..)) import Text.Printf import qualified Data.Text as T import qualified Data.Vector.Strict as V @@ -57,10 +57,11 @@ lowerVal :: Env -> Val -> Wasm.Expr lowerVal g (ValLit l) = case l of - LitInt n -> [ ins "i32.const" [sxp n] ] + LitInt n -> ins "i32.const" [sxp n] + LitBool b -> ins "i32.const" [sxp @Int $ if b then 1 else 0] _ -> _ -lowerVal g (ValVar x) = [ ins "local.get" [sxp l] ] +lowerVal g (ValVar x) = ins "local.get" [sxp l] where l = V.elemIndex x g.vars ^?! _Just @@ -75,14 +76,20 @@ lower' g (ExpPrim p rs e) = where r = head rs +lower' g (ExpIf c t f) = + lowerVal g c + <> Wasm.if' (Wasm.result [i32]) + (lower' g t) + (lower' g f) + lowerBinOp :: _ -> _ -> _ -> _ -> _ -> _ -> Wasm.Expr lowerBinOp op g x y r e = lowerVal g x <> lowerVal g y - <> [ ins op [] ] - <> [ ins "local.set" [sxp n] ] + <> ins op [] + <> ins "local.set" [sxp n] <> lower' g' e where g' = g & #vars <>~ [r] @@ -92,6 +99,9 @@ lowerBinOp op g x y r e = lower :: Exp -> Eff es Text lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do - idx <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ -> + main <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ -> lower' emptyEnv e - Wasm.export "main" "func" idx + Wasm.export "main" "func" main + +lowerProgram :: Program -> Eff es Text +lowerProgram (MkProgram e) = lower e diff --git a/app/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs similarity index 62% rename from app/Gyehoek/CPS/Syntax.hs rename to src/Gyehoek/CPS/Syntax.hs index 5f52c41..52380ee 100644 --- a/app/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -3,9 +3,13 @@ module Gyehoek.CPS.Syntax ( Val(..) , Kappa(..) + , Lambda(..) , Exp(..) , Name(..) , Prim(..) + , Program(..) + , Lit(..) + , pattern Void , pattern Halt , pattern Halt1 , _MkKappa @@ -17,7 +21,7 @@ module Gyehoek.CPS.Syntax import Language.SexpGrammar qualified as S import Gyehoek.Sexp qualified -import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit) +import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void) import Data.Text (Text) import Data.List (List) import GHC.Generics (Generic) @@ -28,6 +32,9 @@ import Data.Text qualified as T import Data.Generics.Labels import Prelude hiding ((.), id) import Data.List.NonEmpty (NonEmpty) +import Data.InvertibleGrammar.Base qualified as IGB +import Data.InvertibleGrammar.Base ((:-)((:-))) +import qualified Data.InvertibleGrammar as IG -- Data types @@ -40,11 +47,16 @@ data Val data Kappa = MkKappa (List Name) Exp deriving (Show, Generic) +data Lambda = MkLambda (List Name) Name Exp + deriving (Show, Generic) + data Exp = ExpPrim (Prim Val) (List Name) Exp | ExpFix (NonEmpty (Name, Kappa)) Exp - | ExpApply Val (List Val) + | ExpLet (NonEmpty (Name, Lambda)) Exp + | ExpContinue Name (List Val) | ExpIf Val Exp Exp + | ExpApply Val (List Val) deriving (Show, Generic) pattern Halt :: List Val -> Exp @@ -53,6 +65,14 @@ pattern Halt xs = ExpApply (ValVar "halt") xs pattern Halt1 :: Val -> Exp pattern Halt1 x = ExpApply (ValVar "halt") [x] +data Def = DefConstant Name Exp + deriving (Show, Generic) + +data Program = MkProgram + { body :: Exp + } + deriving (Show, Generic) + makePrisms ''Kappa makePrisms ''Exp @@ -69,6 +89,17 @@ instance S.SexpIso Val where label = S.keyword >>> S.iso MkName getName var = S.sexpIso +instance S.SexpIso Lambda where + sexpIso = match + $ With (. lambda) + $ End + where + lambda = S.list $ + S.el Gyehoek.Sexp.lambdaKeyword + >>> S.el (S.list (S.rest S.sexpIso)) + >>> S.el S.sexpIso + >>> S.el S.sexpIso + instance S.SexpIso Kappa where sexpIso = match $ With (. kappa) @@ -82,16 +113,27 @@ instance S.SexpIso Kappa where instance S.SexpIso Exp where sexpIso = match $ With (. prim) + $ With (. fix) $ With (. let_) - $ With (. app) + $ With (. continue) $ With (. if_) + $ With (. app) $ End where - let_ = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso - if_ = S.list $ S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso + continue = S.list $ + S.el (S.sym "continue") + >>> S.el S.sexpIso + >>> S.rest S.sexpIso + fix = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso + let_ = Gyehoek.Sexp.let_ "let" S.sexpIso S.sexpIso S.sexpIso + if_ = S.list $ S.el (S.sym "if") + >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso app = S.list $ S.el S.sexpIso >>> S.rest S.sexpIso prim = S.list $ S.el (S.sym "prim") >>> S.el (primSexpIso id (S.sexpIso @Val)) >>> S.el S.sexpIso >>> S.el S.sexpIso + +instance S.SexpIso Program where + sexpIso = with \prog -> S.sexpIso @Exp >>> prog diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs new file mode 100644 index 0000000..4deecd6 --- /dev/null +++ b/src/Gyehoek/Driver.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OrPatterns #-} +module Gyehoek.Driver + (main, lower_e2e, convert_e2e, parse_e2e) + 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 qualified as Cps +import Data.Maybe (fromMaybe) +import Control.Monad +import Text.Pretty.Simple (pShow, pShowNoColor) + + +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.Program +readScm f = + withFile f FS.ReadMode $ \h -> + Sexp.parseSexps @Scm.CommandOrDef f <$> hGetContents h + >>= either error (pure . Scm.MkProgram) + +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 + wat <- lowerProgram cps + withFile opts.output FS.WriteMode \h -> + hPutStrLn h 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) diff --git a/app/Gyehoek/GenSym.hs b/src/Gyehoek/GenSym.hs similarity index 100% rename from app/Gyehoek/GenSym.hs rename to src/Gyehoek/GenSym.hs diff --git a/app/Gyehoek/Options.hs b/src/Gyehoek/Options.hs similarity index 81% rename from app/Gyehoek/Options.hs rename to src/Gyehoek/Options.hs index 642e473..6c80dd3 100644 --- a/app/Gyehoek/Options.hs +++ b/src/Gyehoek/Options.hs @@ -17,7 +17,9 @@ import GHC.Generics (Generic) data Options = MkOptions { -- dumpANF :: Maybe FilePath -- , dumpQBE :: Maybe FilePath - output :: FilePath + dumpCPS :: Bool + , dumpParsed :: Bool + , output :: FilePath , sourceFile :: FilePath } deriving (Show, Generic) @@ -45,7 +47,12 @@ parseOutput = strOption <> value "-" ) +parseDumpCPS = switch (long "dump-cps") +parseDumpParsed = switch (long "dump-parsed") + parser :: Parser Options parser = MkOptions - <$> parseOutput + <$> parseDumpCPS + <*> parseDumpParsed + <*> parseOutput <*> argument str (metavar "FILE") diff --git a/app/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs similarity index 70% rename from app/Gyehoek/Scheme/Syntax.hs rename to src/Gyehoek/Scheme/Syntax.hs index 7fc40e1..45fa649 100644 --- a/app/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE DerivingStrategies #-} @@ -9,10 +10,13 @@ module Gyehoek.Scheme.Syntax ( Name(..) , Prim(..) , Lit(..) - , Define(..) + , Def(..) , Exp(..) , Sexp(..) + , Program(..) + , CommandOrDef(..) , primSexpIso + , pattern Void ) where @@ -21,6 +25,7 @@ import Data.List (List) import Language.SexpGrammar ( SexpIso(..), list, el, (>>>), rest, sym, symbol ) import Language.SexpGrammar qualified as Sexp +import Language.Sexp.Located qualified as S import Language.SexpGrammar.Generic import GHC.Generics import Prelude hiding ((.), id) @@ -28,9 +33,10 @@ import Control.Category import Data.List.NonEmpty (NonEmpty ((:|))) import Gyehoek.Sexp qualified import Gyehoek.GenSym (Gen) -import Control.Lens (Each) +import Control.Lens import Data.String (IsString) import Data.Hashable (Hashable) +import Control.Lens.Unsound (prismSum) newtype Name = MkName { getName :: Text } @@ -63,16 +69,18 @@ data Lit | LitQuote Sexp deriving (Show, Generic) -data Define - = DefineConstant Name Exp - | DefineProcedure Name (List Name) (List Exp) +pattern Void :: Lit +pattern Void = LitNil + +data Def + = DefConstant Name Exp + | DefProcedure Name (List Name) (List Exp) deriving (Show, Generic) data Exp = ExpLet (NonEmpty (Name, Exp)) Exp | ExpPrim (Prim Exp) | ExpBegin (List Exp) - | ExpDefine Define | ExpIf Exp Exp Exp | ExpLit Lit | ExpLambda (List Name) Exp @@ -86,6 +94,28 @@ data Sexp | SexpLit Lit deriving (Show, Generic) +data CommandOrDef + = Command Exp + | Definition Def + | Begin (List CommandOrDef) + deriving (Show, Generic) + +data Program = MkProgram + { commandsAndDefs :: List CommandOrDef + } + deriving (Show, Generic) + +instance Each Program Program (Either Exp Def) (Either Exp Def) where + each = #commandsAndDefs . each . go + where + inj = either Command Definition + toeither (Command e) = Left e + toeither (Definition d) = Right d + go :: Traversal' CommandOrDef (Either Exp Def) + go k (Command e) = inj <$> k (Left e) + go k (Definition d) = inj <$> k (Right d) + go k (Begin xs) = Begin <$> traverse (go k) xs + instance SexpIso Name where @@ -124,10 +154,19 @@ instance SexpIso Lit where sexpIso = match $ With (. sexpIso) $ With (. sym "nil") - $ With (. sexpIso) + $ With (. bool) $ With (. sexpIso) $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso) $ End + where + bool :: Sexp.SexpGrammar Bool + bool = Sexp.hashed $ Sexp.partialOsi f g + where + f (S.Symbol ("t";"true")) = Right True + f (S.Symbol ("f";"false")) = Right False + f _ = Left $ Sexp.expected "bool" + g True = S.Symbol "true" + g False = S.Symbol "false" instance SexpIso Sexp where sexpIso = match @@ -136,7 +175,7 @@ instance SexpIso Sexp where $ With (\lit -> lit . sexpIso) $ End -instance SexpIso Define where +instance SexpIso Def where sexpIso = match $ With (. defconst) $ With (. defun) @@ -151,7 +190,6 @@ instance SexpIso Exp where $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso) $ With (. sexpIso) $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso)) - $ With (. sexpIso) $ With (. if_) $ With (. sexpIso) $ With (. lam) @@ -164,3 +202,12 @@ instance SexpIso Exp where ( el Gyehoek.Sexp.lambdaKeyword >>> el (sexpIso @(List Name)) >>> el sexpIso ) + +instance SexpIso CommandOrDef where + sexpIso = match + $ With (\_Command -> _Command . sexpIso) + $ With (\_Definition -> _Definition . sexpIso) + $ With (\_Begin -> _Begin . bgn) + $ End + where + bgn = list $ el (sym "begin") >>> rest sexpIso diff --git a/app/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs similarity index 80% rename from app/Gyehoek/Sexp.hs rename to src/Gyehoek/Sexp.hs index ea90a8f..796d3f0 100644 --- a/app/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -2,6 +2,8 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} module Gyehoek.Sexp ( let_ , sexp @@ -21,6 +23,8 @@ module Gyehoek.Sexp , lambdaKeyword , encodePrettyWith , encodePretty + , UglySexpIso(..) + , AsSexpIso(..) ) where @@ -45,6 +49,8 @@ import qualified Data.Text.IO as TIO import Control.Monad (join) import qualified Language.Sexp.Located as SexpLoc import Data.Void (absurd) +import Data.Coerce (coerce) +import qualified Data.Map sexp :: SexpIso a => Iso' a Text @@ -150,3 +156,30 @@ kappaKeyword = coproduct [ sym "κ", sym "kappa" ] lambdaKeyword :: Grammar Position (Sexp :- t) t lambdaKeyword = coproduct [ sym "λ", sym "lambda" ] + + + +class UglySexpIso a where + uglySexpIso :: SexpGrammar a + +newtype AsSexpIso a = AsSexpIso a +newtype AsUglySexpIso a = AsUglySexpIso a + +asSexpIso :: Grammar p (a :- t) (AsSexpIso a :- t) +asSexpIso = Sexp.iso AsSexpIso (\(AsSexpIso x) -> x) + +instance UglySexpIso a => SexpIso (AsUglySexpIso a) where + sexpIso = uglySexpIso @a >>> Sexp.iso coerce coerce + +instance SexpIso a => UglySexpIso (AsSexpIso a) where + uglySexpIso = sexpIso >>> Sexp.iso (\x -> AsSexpIso x) (\(AsSexpIso x) -> x) + +-- why not work +-- deriving via AsSexpIso Text instance UglySexpIso Text + +instance UglySexpIso Text where uglySexpIso = sexpIso +instance UglySexpIso Integer where uglySexpIso = sexpIso +instance UglySexpIso Int where uglySexpIso = sexpIso +instance UglySexpIso Bool where uglySexpIso = sexpIso +instance UglySexpIso Double where uglySexpIso = sexpIso +instance UglySexpIso () where uglySexpIso = sexpIso diff --git a/app/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs similarity index 82% rename from app/Gyehoek/Wasm.hs rename to src/Gyehoek/Wasm.hs index be1deee..7b3b018 100644 --- a/app/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE DerivingVia #-} module Gyehoek.Wasm ( defun , deftype @@ -24,6 +25,9 @@ module Gyehoek.Wasm , export , ins , sxp + , result + , param + , if' ) where @@ -32,7 +36,7 @@ import Language.SexpGrammar import Language.SexpGrammar qualified as Sexp import Language.SexpGrammar.Generic import Data.List (List) -import GHC.Generics (Generic) +import GHC.Generics (Generic, Generically(..)) import Data.Text (Text) import Data.String (IsString (fromString)) import Text.Printf @@ -202,12 +206,15 @@ instance SexpIso Module where <> (m ^.. #functions . each . to sxp) <> (m ^.. #exports . each . to sxp) +instance Each Expr Expr Instr Instr where + each = #MkExpr . each + sxp :: SexpIso a => a -> Sexp sxp e = Sexp.toSexp sexpIso e ^?! _Right -ins :: Text -> List Sexp -> Instr -ins op [] = MkInstr $ Symbol op -ins op xs = MkInstr . ParenList $ Symbol op : xs +ins :: Text -> List Sexp -> Expr +ins op [] = [ MkInstr $ Symbol op ] +ins op xs = [ MkInstr . ParenList $ Symbol op : xs ] instance IsString Sexp where fromString = Symbol . T.pack @@ -216,3 +223,35 @@ instance IsList Expr where type Item Expr = Instr fromList = MkExpr . V.fromList toList e = V.toList e.inner + +data ResultType = MkResultType + { params :: List Type + , result :: List Type + } + deriving stock (Generic) + deriving (Semigroup, Monoid) + via Generically ResultType + +param :: List Type -> ResultType +param ts = MkResultType ts mempty + +result :: List Type -> ResultType +result ts = MkResultType mempty ts + +resultTypeSexp :: ResultType -> List Sexp +resultTypeSexp rt = + f "param" (coerce <$> rt.params) <> f "result" (coerce <$> rt.result) + where + f :: Text -> List Sexp -> List Sexp + f _ [] = [] + f kw s = [ ParenList $ Symbol kw : s ] + +-- resultSexp :: ResultType -> Sexp +-- resultSexp rt = ParenList $ Symbol "param" : (coerce <$> rt.result) + +if' :: ResultType -> Expr -> Expr -> Expr +if' rt t f = MkExpr . V.singleton . MkInstr . ParenList $ + [ Symbol "if" ] + <> resultTypeSexp rt + <> [ ParenList $ Symbol "then" : (t ^.. each . to sxp) ] + <> [ ParenList $ Symbol "else" : (f ^.. each . to sxp) ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..102e17e --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,57 @@ +module Main (main) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Silver +import Test.Tasty.Silver.Interactive (defaultMain) +import Data.Traversable +import Gyehoek.Driver qualified as Driver +import System.FilePath +import Data.List (List) +import Data.Functor ((<&>)) +import System.Directory +import Data.Function + + +disabled :: List String +disabled = + [ "square" + ] + +main :: IO () +main = defaultMain =<< goldenTests + +goldenTests :: IO TestTree +goldenTests = do + all_cases <- listDirectory "golden" + let tests = all_cases + & filter (`notElem` disabled) + & fmap ("golden") + pure $ testGroup "golden" + [ watTests tests + , executionTests tests + ] + +watTests :: List FilePath -> TestTree +watTests files = + testGroup "wat" $ files <&> \test -> + let source = test "source.scm" + golden = test "out.wat" + testname = takeFileName test + in goldenVsAction + testname + golden + (Driver.lower_e2e source) + id + +executionTests :: List FilePath -> TestTree +executionTests files = + testGroup "execution" $ files <&> \test -> + let wat = test "out.wat" + testname = takeFileName test + resultfile = test "exec" + in goldenVsProg + testname + resultfile + "wasmtime" + ["--invoke", "main", wat] + ""