README.md

@@ -1,3 +1,3 @@
-# gyehoek-hs (계획)
+# 계획
 
-a (wip) toy compiler for a Scheme-like language. currently targetting [QBE](https://c9x.me/compile/). nabbing from GHC and GNU Guile.
+a WIP compiler for R⁷RS Scheme targeting WebAssembly.

flake.nix

@@ -20,7 +20,6 @@
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          shake-wrapper = final.callPackage ./shake-wrapper.nix {};
           gyehoek-runtime = final.callPackage ./runtime {
             crane-lib = inputs.crane.mkLib final;
           };
@@ -49,7 +48,6 @@
               };
               buildInputs = with final; [
                 haskellPackages.cabal-fmt
-                shake-wrapper
                 wabt
                 nodejs
                 wasm-tools
@@ -88,7 +86,7 @@
         hf.packages.${system} // lib.fix (packages: {
           gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
           default = packages.gyehoek;
-          inherit (pkgs) gyehoek-runtime shake-wrapper;
+          inherit (pkgs) gyehoek-runtime;
         }));
 
       devShells = each-system

gyehoek.cabal

@@ -61,6 +61,7 @@ library
     Gyehoek.Driver
     Gyehoek.GenSym
     Gyehoek.Options
+    Gyehoek.Prelude
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Stack.Syntax
@@ -102,10 +103,11 @@ library
   default-language: GHC2024
 
 test-suite test
-  import:           ghcstuffs, ghcstuffs-dev
-  type:             exitcode-stdio-1.0
-  hs-source-dirs:   test
-  main-is:          Main.hs
+  import:             ghcstuffs, ghcstuffs-dev
+  type:               exitcode-stdio-1.0
+  hs-source-dirs:     test
+  main-is:            Main.hs
+  build-tool-depends: tasty-discover:tasty-discover
   other-modules:
     Gyehoek.Test.CPS.Eval
     Gyehoek.Test.CPS.Stackify
@@ -114,6 +116,7 @@ test-suite test
     Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp
     Gyehoek.Test.Stack.VM
+    Root
 
   build-depends:
     , base
@@ -132,4 +135,4 @@ test-suite test
     , tasty-silver
     , text
 
-  default-language: GHC2024
+  default-language:   GHC2024

repl

@@ -1,2 +0,0 @@
-#!/usr/bin/env sh
-cabal repl --repl-options "-interactive-print=Text.Pretty.Simple.pPrint" --build-depends pretty-simple

shake-wrapper.nix

@@ -1,14 +0,0 @@
-{ runCommandLocal, makeWrapper, lib, haskellPackages }:
-
-let
-  our-ghc = haskellPackages.ghc.withPackages (ps: [
-    ps.shake
-  ]);
-in runCommandLocal
-  "shake-wrapper"
-  { nativeBuildInputs = [ makeWrapper ]; }
-  ''
-    mkdir -p $out/bin
-    makeWrapper ${lib.getExe haskellPackages.shake} $out/bin/shake \
-      --prefix PATH : ${lib.makeBinPath [our-ghc]}
-  ''

src/Gyehoek/CPS/Close.hs

@@ -4,35 +4,17 @@ module Gyehoek.CPS.Close
   ) where
 
 import Gyehoek.CPS.Syntax
-import Effectful
-import Data.Functor.Foldable
-import Control.Monad ((>=>))
-import Control.Lens
-import Data.List.NonEmpty (NonEmpty)
-import qualified Data.HashSet as HS
-import qualified Data.Set.Ordered as O
-import Data.Set.Ordered (OSet)
 import Gyehoek.GenSym
-import Data.String.Interpolate (i)
-import Debug.Pretty.Simple
-import Data.HashSet (HashSet)
+import Gyehoek.Prelude
 
 
-cataM
-  :: (Monad m, Traversable (Base t), Recursive t)
-  => (Base t a -> m a) -> t -> m a
-cataM f = cata (sequenceA >=> f)
-
 close :: GenSym :> es => Exp -> Eff es Exp
-
 close = transformM \case
-
   ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
     f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code")
     -- it would probably be most sane to generate a symbol for `env`,
-    -- but we're reusing the lambda binding for the sake of recursive
-    -- reverences.
-    -- env <- gensym' @Name "env"
+    -- but we're reusing the lambda binding so we don't have to
+    -- explicitly substitute recursive calls.
     let frees = freeWithBound' [f] lam
     let m' = ifoldr
              (\n x q -> [cps|(prim (env-ref #{f} #{n})
@@ -55,45 +37,5 @@ close = transformM \case
 
   e -> pure e
 
-  e -> error [i|unimplemented case: #{e}|]
-
-  -- lam@(ExpLambdaF bs m) -> do
-  --   env <- gensym' @Name "env"
-  --   let upvalBinds = free' (embed lam)
-  --         & itraversed %@~ \i x -> (x, [cps|(env-ref #{env} #{i})|])
-  --   let upvals = upvalBinds ^.. each . _1
-  --   pure [cps|
-  --     (make-closure (λ (#{env} ##{bs})
-  --                     (let #{upvalBinds}
-  --                       #{m}))
-  --                   ##{upvals})
-  --    |]
-  -- ExpApplyF f xs ->
-  --   pure [scm|
-  --     (apply-closure #{f} ##{xs})
-  --   |]
-
 closeProgram :: GenSym :> es => Program -> Eff es Program
 closeProgram = traverseOf #body close
-
-curriedadd :: Program
-curriedadd = [cps|
-  (letrec ((curried-add
-            (λ (n ktail1)
-              (letrec ((curried-add-in
-                        (λ (m ktail2)
-                          (prim (+ n m)
-                                (κ (x0) (continue ktail2 x0))))))
-                (continue ktail1 curried-add-in)))))
-    (letrec ((k0 (κ (adder) (adder 4 halt))))
-      (curried-add 5 k0)))
-|]
-
-square :: Program
-square = [cps|
-(letrec ((lambda-body0 (λ (x lambda-tail1)
-                (prim (* x x) (κ (r2) (continue lambda-tail1 r2))))))
-  (letrec
-    ((r3 (κ (x4) (continue halt x4))))
-    (lambda-body0 5 r3)))
-|]

src/Gyehoek/CPS/Convert.hs

@@ -9,16 +9,9 @@ import Gyehoek.CPS.Syntax
 import Gyehoek.Scheme.Syntax qualified as Scm
 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
-import qualified Gyehoek.Sexp
-import Data.String.Interpolate (i)
-import Data.Functor (unzip)
-import Data.List (List)
-import Prelude hiding (unzip)
-import Debug.Pretty.Simple (pTraceShowMForceColor)
+import Gyehoek.Prelude
 
 
 -- 뻘짓이어라
@@ -30,18 +23,16 @@ telescope f = Cont.runCont . traverse (Cont.cont . f)
 
 
 
-pattern Atomic e <-
-  e@( Scm.ExpLambda _ _
-  ; Scm.ExpVar _
-  ; Scm.ExpLit _ )
-
 -- | Transform an expression with a meta-continuation.
 convert
   :: forall es. (GenSym :> es)
   => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
 
 convert (Scm.ExpVar x) k = k $ ValVar x
-convert (Scm.ExpLit l) k = k $ ValLit l
+convert (Scm.ExpLit l) k = k . ValImm $ case l of
+  LitInt n -> ImmInt n
+  LitBool b -> ImmBool b
+  _ -> _
 
 -- special case: call/cc is desugared during cps-conversion...
 convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
@@ -109,8 +100,6 @@ convert (Scm.ExpLetRec bs m) k = do
     (letrec #{bs''} #{m'})
   |]
 
--- convert e k = error [i|unimplemented expr: #{e}|]
-
 convertLambda
   :: GenSym :> es
   => List Name -> Scm.Exp -> Eff es Lambda
@@ -121,10 +110,7 @@ convertLambda bs m = do
 
 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
+  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)
 
 convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
 convertExp e = convert e (pure . Halt1)

src/Gyehoek/CPS/Eval.hs

@@ -5,24 +5,13 @@ module Gyehoek.CPS.Eval
   ) where
 
 import Gyehoek.CPS.Syntax
-import Data.String.Interpolate (i)
-import Data.HashMap.Strict (HashMap)
 import Control.Lens
 import Data.Maybe (fromMaybe)
-import Data.Generics.Labels ()
-import GHC.Generics (Generic)
-import Data.List (List)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
-import Debug.Pretty.Simple (pTraceShowId)
-import qualified Data.Text as T
+import Gyehoek.Prelude
 
 
-data Code
-  = CodeKap (List Obj -> List Obj)
-  | CodeLam (List Obj -> Name -> List Obj)
-  deriving (Show, Generic)
-
 data Env = MkEnv
   { vars :: HashMap Name Obj
   , labels :: HashMap Name (Env, Abs)
@@ -71,14 +60,16 @@ evalVal :: Env -> Val -> Obj
 evalVal g = \case
   ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
   ValImm x -> ObjImm x
-  ValLit l -> ObjImm $ case l of
-    LitInt n -> ImmInt n
-    LitBool b -> ImmBool b
 
 emptyEnv :: Env
 emptyEnv = MkEnv
   { vars = mempty
-  , labels = H.singleton "halt" $
+  -- a kinda silly hack to make sure `halt` is handled correctly when
+  -- it appears as the tail continuation of an application. the
+  -- special case of `eval` responsible for `halt` only covers terms
+  -- of the form `(continue $halt xs …)`; other terms such as
+  -- `($some-fn xs $halt)` just see an undefined label `$halt`.
+  , labels = H.singleton "halt"
     ( emptyEnv
     , AbsKappa' ["h0"] $ Halt [ValVar "h0"]
     )
@@ -86,22 +77,3 @@ emptyEnv = MkEnv
 
 evalProgram :: Program -> List Obj
 evalProgram (MkProgram e) = eval emptyEnv e
-
-curriedadd :: Program
-curriedadd = [cps|
-(letrec ((curried-add
-          (λ (n ktail1)
-            (letrec ((curried-add-in
-                      (λ (m ktail2)
-                        (prim (+ n m)
-                              (κ (x0) (continue ktail2 x0))))))
-              (continue ktail1 curried-add-in)))))
-  (letrec ((k0 (κ (adder) (adder 4 halt))))
-    (curried-add 5 k0)))
-|]
-
-idfn = [cps|
-        (letrec ((id (λ (x ktail)
-                       (continue ktail x))))
-          (id 456 halt))
-      |] :: Program

src/Gyehoek/CPS/Lower.hs

@@ -5,20 +5,15 @@
 {-# LANGUAGE MultilineStrings #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ApplicativeDo #-}
-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 {-# LANGUAGE RecursiveDo #-}
 {- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Lower
   (lower, lowerProgram) where
 
 import Gyehoek.CPS.Syntax
-import Data.Generics.Labels ()
-import Effectful
-import Data.Text (Text)
 import Data.Vector.Strict (Vector)
 import Control.Lens hiding (op)
 import Numeric.Natural
-import GHC.Generics (Generic)
 import qualified Data.Vector.Strict as V
 import Gyehoek.Wasm qualified as Wasm
 import Gyehoek.Wasm hiding (Expr)
@@ -26,12 +21,9 @@ import Language.Sexp.Located qualified as SL
 import Control.Monad.Fix
 import qualified Gyehoek.Sexp
 import Data.Text qualified as T
-import Data.List qualified
 import Data.Foldable (fold)
-import Gyehoek.Sexp (encodeOrShow, toSexp)
-import Debug.Pretty.Simple
-import GHC.Stack (HasCallStack)
-import Data.String.Interpolate
+import Gyehoek.Sexp (encodeOrShow)
+import Gyehoek.Prelude
 
 
 data Env = MkEnv
@@ -90,13 +82,13 @@ popArg n = [expr|
 
 lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr
 
-lowerVal g (ValLit l) =
-  pure $ case l of
-    LitInt n -> [expr|
+lowerVal g (ValImm imm) =
+  pure $ case imm of
+    ImmInt n -> [expr|
       (i32.const #{n})
       ##{makeSmallFixnum}
     |]
-    LitBool b -> [expr|
+    ImmBool b -> [expr|
       (i32.const #{b'})
       ref.i31
     |]

src/Gyehoek/CPS/Stackify.hs

@@ -9,18 +9,12 @@ import Gyehoek.CPS.Syntax
 import Gyehoek.Stack.Syntax qualified as Stk
 import Data.Sequence (Seq)
 import Data.Sequence qualified as Seq
-import Effectful
 import Gyehoek.GenSym
 import Effectful.Writer.Static.Shared
-import Control.Lens
-import Data.String.Interpolate
-import Gyehoek.Stack.Syntax (Imm(..))
-import GHC.Generics (Generic)
 import Data.Foldable
-import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as H
-import Data.List (List, elemIndex)
-import GHC.Exts (IsList(fromList))
+import Data.List (elemIndex)
+import Gyehoek.Prelude
 
 
 type Stackify = Writer Stk.Program
@@ -93,8 +87,6 @@ stackify _ e = error [i|unimplemented exp: #{e}|]
 
 stackifyVal :: Env -> Val -> Stk.Val
 stackifyVal g = \case
-  ValLit (LitInt n) -> Stk.ValImm (ImmInt n)
-  ValLit (LitBool b) -> Stk.ValImm (ImmBool b)
   ValImm imm -> Stk.ValImm imm
   ValVar v -> var g v
   v -> error [i|unimplemented val: #{v}|]

src/Gyehoek/CPS/Syntax.hs

@@ -36,8 +36,6 @@ module Gyehoek.CPS.Syntax
   , pattern AbsKappa'
   , Abs(..)
   , Free(..)
-  , Vars(..)
-  , Subst(..)
   , pattern ValLabel
   , labelName -- don't like that this is part of the api
   )
@@ -45,38 +43,26 @@ module Gyehoek.CPS.Syntax
 
 import Language.SexpGrammar qualified as S
 import Gyehoek.Sexp qualified
-import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void, getName)
-import Data.List (List)
-import GHC.Generics (Generic)
-import Data.Generics.Labels ()
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
 import Language.SexpGrammar.Generic
 import Control.Category
-import Control.Lens hiding (op)
 import Prelude hiding ((.), id)
-import Data.List.NonEmpty (NonEmpty)
 import Language.Haskell.TH.Quote (QuasiQuoter)
-import Data.Data (Data)
 import Language.Sexp.Located (Sexp)
 import qualified Data.InvertibleGrammar.Base as IG
-import qualified Gyehoek.Scheme.Syntax as Gyehoek
 import Data.InvertibleGrammar.Base (type (:-)((:-)))
-import Data.HashSet (HashSet)
 import qualified Data.HashSet as HS
-import Data.Hashable (Hashable)
 import Data.Monoid (Endo)
-import Data.Containers.ListUtils (nubOrd)
 import Data.Functor.Foldable.TH
-import Data.Functor.Foldable (Recursive(..), Corecursive (..))
-import Control.DeepSeq (NFData)
 import qualified Gyehoek.Sexp as GS
 import qualified Language.Sexp.Located as SL
 import Data.Data.Lens (uniplate)
+import Gyehoek.Prelude hiding (op)
 
 -- Data types
 
 data Val
   = ValImm Imm
-  | ValLit Lit
   | ValVar Name
   deriving (Show, Generic, Data, Eq)
 
@@ -186,7 +172,6 @@ instance Plated Exp where
 
 instance S.SexpIso Val where
   sexpIso = match
-    $ With (\lit -> lit . S.sexpIso)
     $ With (\imm -> imm . S.sexpIso)
     $ With (\var -> var . S.sexpIso)
     $ End
@@ -385,52 +370,3 @@ instance Vars Exp where
   vars k (ExpPrim p kap) = ExpPrim <$> vars k p <*> pure kap
   vars k (ExpContinue kname xs) = ExpContinue <$> k kname <*> pure xs
   vars _ e = pure e
-
-
-
-data Scope
-  = Bind (List Name) (List Scope)
-  | Use (List Name) (List Scope)
-  deriving (Show, Eq)
-
-makeBaseFunctor ''Scope
-
-class Scoped a where
-  scope :: a -> Scope
-
-instance Scoped Kappa where
-  scope (MkKappa bs e) =
-    Bind bs [scope e]
-
-instance Scoped Lambda where
-  scope (MkLambda bs k e) = Bind (bs ++ [k]) [scope e]
-
-instance Scoped Abs where
-  scope = \case
-    AbsKappa k -> scope k
-    AbsLambda l -> scope l
-
-instance Scoped Val where
-  scope = \case
-    ValVar x -> Use [x] []
-    _ -> Use [] []
-
-instance Scoped Exp where
-  scope = \case
-    ExpApply f xs k ->
-      Use (((f:xs) ^.. each . _ValVar) ++ [k]) []
-    ExpLetRec bs e ->
-      Bind (bs ^.. each . _1) $
-        (bs ^.. each . _2 . to scope)
-        ++ [scope e]
-    ExpPrim p k ->
-      Use (p ^.. each . _ValVar) [scope k]
-    ExpContinue k xs ->
-      Use (k : (xs ^.. each . _ValVar)) []
-    ExpIf c t f ->
-      Use (c ^.. _ValVar) [ scope t, scope f ]
-
-
-
-class Subst a where
-  substWith :: (Name -> Maybe Val) -> a -> a

src/Gyehoek/Driver.hs

@@ -3,7 +3,6 @@ module Gyehoek.Driver
   where
 
 import Gyehoek.Options
-import Data.Text (Text)
 import Prelude hiding (readFile)
 import Options.Applicative
 import Control.Lens
@@ -23,21 +22,17 @@ import Gyehoek.CPS.Eval 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 qualified as Stk
-import Effectful.Exception
 import Gyehoek.CPS.Close (closeProgram)
 import Control.Lens.Extras (is)
 import Control.Arrow ((>>>))
+import Gyehoek.Prelude
 
 
 main :: IO ()

src/Gyehoek/Options.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE RecordWildCards #-}
 module Gyehoek.Options
   ( Options(..)
   , Runtime(..)
@@ -6,14 +7,9 @@ module Gyehoek.Options
   )
   where
 
-import System.IO (Handle)
-import Data.HashSet (HashSet)
 import Options.Applicative
-import System.FilePath
-import qualified Data.HashSet as HS
-import Control.Lens hiding (argument)
-import GHC.Generics (Generic)
 import Data.Foldable
+import Gyehoek.Prelude hiding (argument)
 
 
 data Runtime = Stackify | Wasm | CPS
@@ -31,55 +27,35 @@ data Options = MkOptions
   }
   deriving (Show, Generic)
 
--- osPath :: ReadM _
--- osPath = eitherReader $
---   (_Left %~ show) . encodeUtf @(Either _)
-
--- parseDumpQBE =
---   optional $ strOption
---     ( long "dump-qbe"
---     <> metavar "FILE"
---     )
-
--- parseDumpANF =
---   optional $ strOption
---     ( long "dump-anf"
---     <> metavar "FILE"
---     )
-
-parseOutput = strOption
-    ( long "output"
-    <> short 'o'
-    <> metavar "FILE"
-    <> value "-"
-    )
-
-parseRuntime = option rdr . fold $
-  [ long "runtime"
-  , short 'R'
-  , value Nothing
-  ]
-  where
-    rdr = maybeReader \case
-      "stackify" -> Just (Just Stackify)
-      "wasm" -> Just (Just Wasm)
-      "cps" -> Just (Just CPS)
-      "none" -> Just Nothing
-      _ -> Nothing
-
-parseDumpClosed = switch (long "dump-closed")
-parseDumpCPS = switch (long "dump-cps")
-parseDumpStackified = switch (long "dump-stackified")
-parseDumpParsed = switch (long "dump-parsed")
-parseInspectWasm = switch $ long "inspect-wasm" <> short 'p'
+runtimeReader = maybeReader \case
+  "stackify" -> Just (Just Stackify)
+  "wasm" -> Just (Just Wasm)
+  "cps" -> Just (Just CPS)
+  "none" -> Just Nothing
+  _ -> Nothing
 
 parser :: Parser Options
-parser = MkOptions
-  <$> parseDumpClosed
-  <*> parseDumpCPS
-  <*> parseDumpParsed
-  <*> parseDumpStackified
-  <*> parseRuntime
-  <*> parseInspectWasm
-  <*> parseOutput
-  <*> argument str (metavar "FILE")
+parser = do
+  dumpClosed <- switch (long "dump-closed")
+  dumpCPS <- switch (long "dump-cps")
+  dumpStackified <- switch (long "dump-stackified")
+  dumpParsed <- switch (long "dump-parsed")
+  inspectWasm <- switch $ long "inspect-wasm" <> short 'p'
+  runtime <- option runtimeReader . fold $
+    [ long "runtime"
+    , short 'R'
+    , value (Just Stackify)
+    , completeWith ["stackify","wasm","cps","none"]
+    , showDefaultWith $ const "stackify"
+    ]
+  output <- strOption . fold $
+    [ long "output"
+    , short 'o'
+    , metavar "FILE"
+    , value "-"
+    ]
+  sourceFile <- argument str . fold $
+    [ metavar "FILE"
+    , action "file"
+    ]
+  pure $ MkOptions {..}

src/Gyehoek/Prelude.hs

@@ -0,0 +1,34 @@
+module Gyehoek.Prelude
+  ( module Control.Lens
+  , module Effectful
+  , module Data.Generics.Labels -- exports instances
+  , module Data.String.Interpolate
+  , Text
+  , List
+  , Generic
+  , Data
+  , NFData
+  , HashMap
+  , HashSet
+  , coerce
+  , IsList(fromList)
+  , HasCallStack
+  , Hashable
+  ) where
+
+import Control.Lens
+import Data.List (List)
+import Data.Text (Text)
+import Effectful (Eff, runEff, runPureEff, (:>))
+import GHC.Generics (Generic)
+import Data.Data (Data)
+import Control.DeepSeq (NFData)
+import Data.HashMap.Strict (HashMap)
+import Data.HashSet (HashSet)
+import Data.Coerce (coerce)
+import GHC.Exts (IsList(..))
+import Data.Generics.Labels ()
+import Data.String.Interpolate
+import GHC.Stack (HasCallStack)
+import Data.Hashable (Hashable)
+

src/Gyehoek/Scheme/Syntax.hs

@@ -35,27 +35,21 @@ module Gyehoek.Scheme.Syntax
   )
   where
 
-import Data.Text (Text)
-import Data.List (List, intersperse)
+import Data.List (intersperse)
 import Language.SexpGrammar
   ( SexpIso(..), list, el, rest, sym, symbol )
 import Language.SexpGrammar qualified as Sexp
 import Language.SexpGrammar.Generic
 import Effectful
-import GHC.Generics (Generic)
 import Prelude hiding ((.), id)
 import Control.Category
-import Data.List.NonEmpty (NonEmpty)
 import Gyehoek.Sexp qualified as GS
 import Gyehoek.GenSym (Gen)
 import Control.Lens
 import Data.Generics.Labels ()
 import Data.String (IsString)
-import Data.Hashable (Hashable)
-import Data.Data (Data)
 import Data.Functor.Foldable.TH (makeBaseFunctor)
 import Data.Functor.Foldable hiding (fold)
-import Data.HashSet (HashSet)
 import qualified Data.HashSet as HS
 import Data.Foldable (fold, toList)
 import Language.Haskell.TH.Quote (QuasiQuoter)
@@ -63,9 +57,8 @@ import Effectful.FileSystem (runFileSystem)
 import qualified Effectful.FileSystem.IO as FS
 import qualified Data.Text.Encoding as T
 import qualified Effectful.FileSystem.IO.ByteString as FB
-import Control.DeepSeq (NFData)
 import qualified Data.Set.Ordered as O
-import Data.Sequence (Seq)
+import Gyehoek.Prelude
 
 
 newtype Name = MkName { inner :: Text }

src/Gyehoek/Stack/Syntax.hs

@@ -18,24 +18,15 @@ module Gyehoek.Stack.Syntax
   ) where
 
 import Control.Lens
-import Data.List (List)
-import GHC.Generics (Generic)
-import Data.HashMap.Strict (HashMap)
-import Language.SexpGrammar (SexpIso, (>>>), (:-))
+import Language.SexpGrammar (SexpIso, (>>>))
 import Language.SexpGrammar qualified as S
 import Language.SexpGrammar.Generic
-import Data.Coerce (coerce)
-import Data.Text (Text)
 import qualified Gyehoek.Sexp
-import Language.Haskell.TH.Quote (QuasiQuoter)
-import Data.Data (Data)
-import qualified Data.HashMap.Strict as H
-import Effectful
 import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
 import GHC.Exts (IsList(..))
 import Data.List (intersperse)
-import Control.DeepSeq (NFData)
 import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName)
+import Gyehoek.Prelude
 
 
 newtype Program = MkProgram

src/Gyehoek/Stack/VM.hs

@@ -9,18 +9,10 @@ module Gyehoek.Stack.VM
   ) where
 
 import Gyehoek.Stack.Syntax
-import Data.List (List)
-import GHC.Generics (Generic)
 import Control.Lens
-import Data.HashMap.Strict (HashMap)
-import Data.Text (Text)
 import qualified Data.HashMap.Strict as H
-import Data.String.Interpolate (i)
-import Gyehoek.Scheme.Syntax (Sexp(..))
-import Debug.Pretty.Simple (pTraceShowIdForceColor)
-import qualified Data.List.NonEmpty as NE
-import Data.Functor (($>))
 import Data.List (unfoldr)
+import Gyehoek.Prelude
 
 
 data VM = MkVM

t.scm

@@ -1,21 +0,0 @@
-(define (-& x y k) (k (- x y)))
-(define (zero?& x k) (k (zero? x)))
-(define (halt x) x)
-
-(letrec ((even? (lambda (n ktail)
-                  (zero?& n
-                          (lambda (x1)
-                            (if x1
-                                #t
-                                (-& n 1
-                                    (lambda (x2)
-                                      (odd? x2 ktail))))))))
-         (odd? (lambda (n ktail)
-                 (zero?& n
-                         (lambda (x1)
-                           (if x1
-                               #f
-                               (-& n 1
-                                   (lambda (x2)
-                                     (even? x2 ktail)))))))))
-  (even? 12 halt))

t.wat

@@ -1,142 +0,0 @@
-(module
-  (import
-    "gyehoek"
-    "write"
-    (func $gh-write (param (ref eq))))
-  (import
-    "gyehoek"
-    "truthy?"
-    (func $gh-truthy? (param (ref eq)) (result i32)))
-  (type $heap-object (sub (struct (field $hash (mut i32)))))
-  (type $cont-type (func (param i32)))
-  (type $cont-stack-type (array (mut (ref null $cont-type))))
-  (type
-    $closure
-    (sub
-      $heap-object
-      (struct
-        (field $hash (mut i32))
-        (field $code (ref $cont-type)))))
-  (global $cont-stack-top (mut i32) (i32.const 0))
-  (global
-    $cont-stack
-    (ref $cont-stack-type)
-    (array.new_default $cont-stack-type (i32.const 128)))
-  (global $arg0 (mut (ref null eq)) (ref.null eq))
-  (global $arg1 (mut (ref null eq)) (ref.null eq))
-  (global $arg2 (mut (ref null eq)) (ref.null eq))
-  (global $arg3 (mut (ref null eq)) (ref.null eq))
-  (global $arg4 (mut (ref null eq)) (ref.null eq))
-  (global $arg5 (mut (ref null eq)) (ref.null eq))
-  (global $arg6 (mut (ref null eq)) (ref.null eq))
-  (global $arg7 (mut (ref null eq)) (ref.null eq))
-  (global $arg8 (mut (ref null eq)) (ref.null eq))
-  (global $arg9 (mut (ref null eq)) (ref.null eq))
-  (global $arg10 (mut (ref null eq)) (ref.null eq))
-  (global $arg11 (mut (ref null eq)) (ref.null eq))
-  (global $arg12 (mut (ref null eq)) (ref.null eq))
-  (global $arg13 (mut (ref null eq)) (ref.null eq))
-  (global $arg14 (mut (ref null eq)) (ref.null eq))
-  (global $arg15 (mut (ref null eq)) (ref.null eq))
-  (global $result (mut (ref null eq)) (ref.null eq))
-  (func
-    $halt
-    (param i32)
-    (@gyehoek begin popArg)
-    (global.get $arg0)
-    ref.as_non_null
-    (@gyehoek end popArg)
-    (global.set $result))
-  (func
-    (param i32)
-    (@gyehoek
-      :origin
-      "(λ (x λ-tail1) (prim (* x x) (κ (r2) (continue λ-tail1 r2))))")
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (@gyehoek
-      :origin
-      "(prim (* x x) (κ (r2) (continue λ-tail1 r2)))")
-    (global.get $arg1)
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    (global.get $arg1)
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    i32.mul
-    (@gyehoek "construct small fixnum")
-    (i32.const 1)
-    i32.shl
-    ref.i31
-    (global.set $arg2)
-    (@gyehoek :origin "(continue λ-tail1 r2)")
-    (@gyehoek "push args")
-    (@gyehoek begin pushArg)
-    (global.get $arg2)
-    (global.set $arg0)
-    (@gyehoek end pushArg)
-    (@gyehoek "nargs")
-    (i32.const 1)
-    (@gyehoek "pop cont stack")
-    (global.get $cont-stack-top)
-    (i32.const 1)
-    i32.sub
-    (global.set $cont-stack-top)
-    (global.get $cont-stack)
-    (global.get $cont-stack-top)
-    (array.get $cont-stack-type)
-    ref.as_non_null
-    (return_call_ref $cont-type))
-  (elem declare funcref (ref.func 3))
-  (func
-    (param i32)
-    (@gyehoek :origin "(κ (x4) (continue halt x4))")
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (@gyehoek begin pushArg)
-    (global.get $arg2)
-    (global.set $arg0)
-    (@gyehoek end pushArg)
-    (return_call $halt (i32.const 1)))
-  (elem declare funcref (ref.func 4))
-  (func
-    $scm-entry
-    (param i32)
-    (@gyehoek
-      :origin
-      "(letrec ((λ-body0 (λ (x λ-tail1) (prim (* x x) (κ (r2) (continue λ-tail1 r2)))))) (letrec ((r3 (κ (x4) (continue halt x4)))) (λ-body0 5 r3)))")
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (i32.const 0)
-    (ref.func 3)
-    (struct.new $closure)
-    (global.set $arg1)
-    (@gyehoek :origin "(λ-body0 5 r3)")
-    (@gyehoek "push cont" :idx 4)
-    (array.set
-      $cont-stack-type
-      (global.get $cont-stack)
-      (global.get $cont-stack-top)
-      (ref.func 4))
-    (global.set
-      $cont-stack-top
-      (i32.add (global.get $cont-stack-top) (i32.const 1)))
-    (@gyehoek :origin "(λ-body0 5 r3)")
-    (@gyehoek "load args")
-    (@gyehoek begin pushArg)
-    (i32.const 5)
-    (@gyehoek "construct small fixnum")
-    (i32.const 1)
-    i32.shl
-    ref.i31
-    (global.set $arg0)
-    (@gyehoek end pushArg)
-    (i32.const 1)
-    (global.get $arg1)
-    (ref.cast (ref $closure))
-    (struct.get $closure $code)
-    (return_call_ref $cont-type)
-    (@gyehoek todo (f' (global.get $arg1)) (ktail 1)))
-  (func
-    (export "main")
-    (call $scm-entry (i32.const 0))
-    (call $gh-write (ref.as_non_null (global.get $result)))))

test/Gyehoek/Test/CPS/Eval.hs

@@ -1,4 +1,4 @@
-module Gyehoek.Test.CPS.Eval (root) where
+module Gyehoek.Test.CPS.Eval where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -8,9 +8,8 @@ import Gyehoek.CPS.Eval qualified as Sut
 import Data.List (List)
 
 
-root :: IO TestTree
-root = pure . testGroup "cps interpreter" $
-  [ prim
+test_cpsInterpreter = testGroup "cps interpreter" $
+  [ primitives
   , testCase "halt with constant" do
       evalsTo [ObjImm (ImmInt 123)] [cps|
         (continue halt 123)
@@ -39,7 +38,7 @@ root = pure . testGroup "cps interpreter" $
 evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
 evalsTo rs p = Sut.evalProgram p @?= rs
 
-prim = testGroup "primitives"
+primitives = testGroup "primitives"
   [ testGroup "arith"
     [ testCase "basic 1" do
         evalsTo [ObjImm (ImmInt 20)] [cps|

test/Gyehoek/Test/CPS/Stackify.hs

@@ -1,4 +1,4 @@
-module Gyehoek.Test.CPS.Stackify (root) where
+module Gyehoek.Test.CPS.Stackify where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -10,8 +10,7 @@ import Gyehoek.GenSym (runGenSym)
 import Effectful
 
 
-root :: IO TestTree
-root = pure . testGroup "stackify" $
+test_stackify =
   [ trivialReturn
   , tailCall
   , prim

test/Gyehoek/Test/CPS/Syntax.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE OverloadedLists #-}
-module Gyehoek.Test.CPS.Syntax (root) where
+module Gyehoek.Test.CPS.Syntax where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -8,14 +8,13 @@ import Gyehoek.CPS.Syntax (cps)
 import Gyehoek.CPS.Syntax qualified as Sut
 
 
-root :: IO TestTree
-root = pure . testGroup "cps syntax" $
-  [ qqTree
-  , freeTree
+test_root = testGroup "cps syntax"
+  [ free
+  , qq
   ]
 
-freeTree :: TestTree
-freeTree = testGroup "free"
+free :: TestTree
+free = testGroup "free"
   [ testCase "lambda" do
     Sut.free' @Sut.Lambda [cps|
       (lambda (x y z k1) (continue k1 x a b c y))
@@ -27,8 +26,8 @@ freeTree = testGroup "free"
         (continue x y k3))|] @=? ["k3"]
   ]
 
-qqTree :: TestTree
-qqTree = testGroup "parser"
+qq :: TestTree
+qq = testGroup "parser"
   [ testCase "lambda" do
       assertEqual "" (Sut.MkLambda ["x","y"] "ktail"
                (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))

test/Gyehoek/Test/Golden.hs

@@ -1,4 +1,4 @@
-module Gyehoek.Test.Golden (root) where
+module Gyehoek.Test.Golden where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Silver
@@ -31,8 +31,8 @@ brokenStackifyTests =
   -- , "callcc-nested1" -- requires closure-conversion
   -- ]
 
-root :: IO TestTree
-root = do
+test_root :: IO TestTree
+test_root = do
   all_cases <- listDirectory "golden"
   let tests = all_cases
             & fmap ("golden"</>)
@@ -43,6 +43,7 @@ root = do
     ]
 
 maybeBroken name broken = applyWhen (name `elem` broken) expectFail
+
 wasmTests :: List FilePath -> IO TestTree
 wasmTests files = do
   cmd <- getEnvDefault "GYEHOEK_RUNTIME"

test/Gyehoek/Test/Scheme/Syntax.hs

@@ -1,4 +1,4 @@
-module Gyehoek.Test.Scheme.Syntax (root) where
+module Gyehoek.Test.Scheme.Syntax where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -7,8 +7,7 @@ import Gyehoek.Scheme.Syntax (scm)
 import Gyehoek.Scheme.Syntax qualified as Sut
 
 
-root :: IO TestTree
-root = pure . testGroup "scheme syntax" $
+test_root = testGroup "scheme syntax" $
   [ freeTree
   ]
 

test/Gyehoek/Test/Sexp.hs

@@ -1,10 +1,4 @@
-module Gyehoek.Test.Sexp
-  ( root
-  , EquivSexp(..)
-  , assertEquiv
-  , equivto
-  )
-  where
+module Gyehoek.Test.Sexp where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -14,8 +8,7 @@ import Gyehoek.Sexp (sx, equivalent)
 import Data.Function (on)
 
 
-root :: IO TestTree
-root = pure . testGroup "sexp" $
+test_root = testGroup "sexp" $
   [ sxTree
   ]
 

test/Gyehoek/Test/Stack/VM.hs

@@ -1,4 +1,4 @@
-module Gyehoek.Test.Stack.VM (root) where
+module Gyehoek.Test.Stack.VM where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -7,8 +7,7 @@ import Gyehoek.Stack.VM qualified as Sut
 import Data.List (List)
 
 
-root :: IO TestTree
-root = pure . testGroup "stack machine" $
+test_root = testGroup "stack machine" $
   [ lit_int
   , procedure
   , prims

test/Main.hs

@@ -1,27 +1,18 @@
 module Main (main) where
 
-import Test.Tasty (TestTree, testGroup)
+-- import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Silver.Interactive (defaultMain)
-import qualified Gyehoek.Test.Golden
-import qualified Gyehoek.Test.Sexp
-import qualified Gyehoek.Test.CPS.Syntax
-import qualified Gyehoek.Test.Scheme.Syntax
-import qualified Gyehoek.Test.Stack.VM
-import qualified Gyehoek.Test.CPS.Stackify
-import qualified Gyehoek.Test.CPS.Eval
+-- import qualified Gyehoek.Test.Golden
+-- import qualified Gyehoek.Test.Sexp
+-- import qualified Gyehoek.Test.CPS.Syntax
+-- import qualified Gyehoek.Test.Scheme.Syntax
+-- import qualified Gyehoek.Test.Stack.VM
+-- import qualified Gyehoek.Test.CPS.Stackify
+-- import qualified Gyehoek.Test.CPS.Eval
+import qualified Root
 
 
 main :: IO ()
-main = defaultMain =<< root
-
-root :: IO TestTree
-root = testGroup "test" <$> sequenceA
-  [ Gyehoek.Test.Golden.root
-  , Gyehoek.Test.Sexp.root
-  , Gyehoek.Test.CPS.Syntax.root
-  , Gyehoek.Test.Scheme.Syntax.root
-  , Gyehoek.Test.Stack.VM.root
-  , Gyehoek.Test.CPS.Stackify.root
-  , Gyehoek.Test.CPS.Eval.root
-  ]
-
+main = do
+  discoveredTests <- Root.tests
+  defaultMain discoveredTests

test/Root.hs

@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC
+  -F -pgmF tasty-discover
+  -optF --no-main
+  -optF --generated-module=Root
+#-}
+module Root where

u.wat

@@ -1,127 +0,0 @@
-(module
- (import "gyehoek" "write" (func $gh-write (param (ref eq))))
- (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq)) (result i32)))
- (type $heap-object (sub (struct (field $hash (mut i32)))))
- (type $cont-type (func (param i32)))
- (type $cont-stack-type (array (mut (ref null $cont-type))))
- (type
-  $closure
-  (sub
-   $heap-object
-   (struct
-    (field $hash (mut i32))
-    (field $code (ref $cont-type)))))
- (global $cont-stack-top (mut i32) (i32.const 0))
- (global
-  $cont-stack
-  (ref $cont-stack-type)
-  (array.new_default $cont-stack-type (i32.const 128)))
- (type $arg-array-type (array (mut (ref null eq))))
- (global
-  $arg-array
-  (ref $arg-array-type)
-  (array.new_default $arg-array-type (i32.const 32)))
- (global $result (mut (ref null eq)) (ref.null eq))
- (func
-  $halt
-  (param i32)
-  (global.get $arg-array)
-  (i32.const 0)
-  (array.get $arg-array-type)
-  ref.as_non_null
-  (global.set $result))
- (func
-  (param i32)
-  (@gyehoek
-   :origin
-   (lambda (x lambda-tail1)
-     (prim (* x x) (kappa (r2) (continue lambda-tail1 r2)))))
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-  (global.get $arg-array)
-  (i32.const 0)
-  (array.get $arg-array-type)
-  ref.as_non_null
-  (local.set 1)
-  (local.get 1)
-  (i31.get_s (ref.cast (ref i31)))
-  (i32.const 1)
-  i32.shr_u
-  (local.get 1)
-  (i31.get_s (ref.cast (ref i31)))
-  (i32.const 1)
-  i32.shr_u
-  i32.mul
-  (i32.const 1)
-  i32.shl
-  ref.i31
-  (local.set 2)
-  (global.get $arg-array)
-  (i32.const 0)
-  (local.get 2)
-  (array.set $arg-array-type)
-  (i32.const 1)
-  (global.get $cont-stack)
-  (global.get $cont-stack-top)
-  (array.get $cont-stack-type)
-  ref.as_non_null
-  (global.get $cont-stack-top)
-  (i32.const 1)
-  i32.sub
-  (global.set $cont-stack-top)
-  (return_call_ref $cont-type))
- (elem declare funcref (ref.func 3))
- (func
-  (param i32)
-  (@gyehoek :origin (kappa (x4) (continue halt x4)))
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-  (global.get $arg-array)
-  (i32.const 0)
-  (array.get $arg-array-type)
-  ref.as_non_null
-  (local.set 1)
-  (global.get $arg-array)
-  (i32.const 0)
-  (local.get 1)
-  (array.set $arg-array-type)
-  (return_call $halt (i32.const 1)))
- (func
-  $scm-entry
-  (param i32)
-  (@gyehoek
-   :origin
-   (letrec ((lambda-body0
-             (lambda (x lambda-tail1)
-               (prim (* x x) (kappa (r2) (continue lambda-tail1 r2))))))
-     (letrec ((r3 (kappa (x4) (continue halt x4))))
-       (lambda-body0 5 r3))))
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-  (i32.const 0)
-  (ref.func 3)
-  (struct.new $closure)
-  (local.set 1)
-  (@gyehoek "push return cont" :idx 4)
-  (array.set $cont-stack-type
-             (global.get $cont-stack)
-             (global.get $cont-stack-top)
-             (ref.func 4))
-  (global.set $cont-stack-top
-              (i32.add (global.get $cont-stack-top)
-                       (i32.const 1)))
-  (@gyehoek "load args")
-  (global.get $arg-array)
-  (i32.const 0)
-  (i32.const 5)
-  (i32.const 1)
-  i32.shl
-  ref.i31
-  (array.set $arg-array-type)
-  (@gyehoek todo (f' (local.get 1)) (ktail 1))
-  (return_call_ref $cont-type
-                   (i32.const 1)
-                   (struct.get $closure $code
-                               (ref.cast (ref $closure) (local.get 1)))))
- (elem declare funcref (ref.func 4))
- (func
-  (export "main")
-  (call $scm-entry (i32.const 0))
-  (call $gh-write (ref.as_non_null (global.get $result)))))

wasmtime.nix

@@ -1,26 +0,0 @@
-# A Wasmtime wrapper that provides our desired configuration.
-{ wasmtime
-, makeWrapper
-, symlinkJoin
-, formats
-, extraSettings ? {}
-}:
-
-let
-  config = {
-    wasm.gc = true;
-  };
-  config-file =
-    (formats.toml {}).generate
-      "gyehoek-wasmtime.toml"
-      (config // extraSettings);
-in symlinkJoin {
-  name = "gyehoek-wasmtime";
-  inherit (wasmtime) version;
-  paths = [ wasmtime ];
-  nativeBuildInputs = [ makeWrapper ];
-  postBuild = ''
-    wrapProgram $out/bin/wasmtime \
-      --add-flags "--config ${config-file}"
-  '';
-}

wasmtime.toml

@@ -1,6 +0,0 @@
-# Comment out certain settings to use default values.
-# For more settings, please refer to the documentation:
-# https://bytecodealliance.github.io/wasmtime/cli-cache.html
-
-[wasm]
-gc=true