doc

gyehoek.cabal

@@ -66,7 +66,7 @@ library
     , base                  ^>=4.21.2.0
     , binary
     , containers
-    , typed-process
+    , cradle
     , effectful
     , effectful-core
     , effectful-plugin
@@ -89,7 +89,6 @@ library
     , text-short
     , unordered-containers
     , vector
-    , bytestring
 
   hs-source-dirs:   src
   default-language: GHC2024

src/Gyehoek/CPS/Lower.hs

@@ -183,10 +183,10 @@ lower' g e@(ExpApply f xs ktail) = do
     (ref.cast (ref $closure))
     (struct.get $closure $code)
     (return_call_ref $cont-type)
-    (@gyehoek todo
-     (f' ##{f'})
-     (ktail #{l}))
-  |]
+    ;; (@gyehoek todo
+    ;;  (f' ##{f'})
+    ;;  (ktail #{l}))
+     |]
 
 lower' g e@(ExpContinue k xs) = do
   let nargs = length xs

src/Gyehoek/CPS/Syntax.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FunctionalDependencies #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
@@ -20,11 +19,6 @@ module Gyehoek.CPS.Syntax
   , _ExpPrim
   , _ExpLetRec
   , _ExpApply
-  , binders
-  , body
-  , op
-  , args
-  , cont
   , cps
   , pattern AbsLambda'
   , pattern AbsKappa'
@@ -54,7 +48,6 @@ import Data.HashSet (HashSet)
 import qualified Data.HashSet as HS
 import Data.Hashable (Hashable)
 import Data.Monoid (Endo)
-import Data.Containers.ListUtils (nubOrd)
 
 -- Data types
 
@@ -63,10 +56,10 @@ data Val
   | ValLit Lit
   deriving (Show, Generic, Data, Eq)
 
-data Kappa = MkKappa { binders :: List Name, body :: Exp }
+data Kappa = MkKappa (List Name) Exp
   deriving (Show, Generic, Data, Eq)
 
-data Lambda = MkLambda { binders :: List Name, ktail :: Name, body :: Exp }
+data Lambda = MkLambda (List Name) Name Exp
   deriving (Show, Generic, Data, Eq)
 
 data Abs
@@ -79,7 +72,7 @@ pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
 data Exp
   = ExpPrim (Prim Val) Kappa
-  | ExpLetRec { binders :: NonEmpty (Name, Abs), body :: Exp }
+  | ExpLetRec (NonEmpty (Name, Abs)) Exp
   | ExpContinue Name (List Val)
   | ExpIf Val Exp Exp
   | ExpApply
@@ -104,24 +97,7 @@ data Program = MkProgram
   deriving (Show, Generic, Data)
 
 makePrisms ''Kappa
--- makeLenses ''Kappa
 makePrisms ''Exp
--- makeLenses ''Exp
--- makeFieldsNoPrefix ''Exp
--- makeFieldsNoPrefix ''Kappa
--- makeLensesWith abbreviatedFields ''Exp
--- makeLensesFor [("binders", "_binders"), ("body", "_body")] ''Exp
-makeFieldsId ''Exp
-makeFieldsId ''Kappa
-makeFieldsId ''Lambda
-
-instance HasBinders Abs (List Name) where
-  binders k (AbsKappa kap) = AbsKappa <$> binders k kap
-  binders k (AbsLambda lam) = AbsLambda <$> binders k lam
-
-instance HasBody Abs Exp where
-  body k (AbsKappa kap) = AbsKappa <$> body k kap
-  body k (AbsLambda lam) = AbsLambda <$> body k lam
 
 
 -- SexpIso instances
@@ -254,29 +230,24 @@ free = go where
 
 -- | Free variables given in the order of their appearance.
 free' :: Exp -> List Name
-free' = nubOrd . goFree HS.empty where
-
-goFreeKap bound (MkKappa xs m) = goFree (bound & insertFrom xs) m
-goFreeLam bound (MkLambda xs k m) = goFree (bound & insertFrom (k:xs)) m
-goFreeAbs bound = \case
-  AbsKappa kap -> goFreeKap bound kap
-  AbsLambda lam -> goFreeLam bound lam
-
-goFree :: HashSet Name -> Exp -> List Name
-goFree bound = \case
-  ExpPrim p k ->
-    p & toListOf (folded . #ValVar . filtered (`notElem` bound))
-      & (<> goFreeKap bound k)
-  ExpLetRec bs m ->
-    foldMapOf (each . _2) (goFreeAbs bound') bs <> goFree bound' m
-    where bound' = bound & insertFrom (bs ^.. each . _1)
-  ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
-  ExpIf c t f ->
-    (c ^.. #ValVar . filtered (`notElem` bound))
-    <> goFree bound t <> goFree bound f
-  ExpApply f xs k ->
-    (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
-    <> (k ^.. filtered (`notElem` bound))
-
-freeLambda :: Lambda -> List Name
-freeLambda (MkLambda {binders,ktail,body}) = _
+free' = go HS.empty where
+  gokap bound (MkKappa xs m) = go (bound & insertFrom xs) m
+  golam bound (MkLambda xs k m) = go (bound & insertFrom (k:xs)) m
+  goabs bound = \case
+    AbsKappa kap -> gokap bound kap
+    AbsLambda lam -> golam bound lam
+  go :: HashSet Name -> Exp -> List Name
+  go bound = \case
+    ExpPrim p k ->
+      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
+        & (<> gokap bound k)
+    ExpLetRec bs m ->
+      foldMapOf (each . _2) (goabs bound') bs <> go bound' m
+      where bound' = bound & insertFrom (bs ^.. each . _1)
+    ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
+    ExpIf c t f ->
+      (c ^.. #ValVar . filtered (`notElem` bound))
+      <> go bound t <> go bound f
+    ExpApply f xs k ->
+      (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
+      <> (k ^.. filtered (`notElem` bound))

src/Gyehoek/Driver.hs

@@ -16,18 +16,11 @@ 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
 
 
 main :: IO ()
@@ -66,31 +59,6 @@ readScm f =
     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 ()
@@ -102,11 +70,8 @@ driver opts = do
   when opts.dumpCPS do
     hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
   wat <- lowerProgram cps
-  if not opts.inspectWasm then
-    withFile opts.output FS.WriteMode \h ->
-      hPutStrLn h wat
-  else
-    inspectWasm wat
+  withFile opts.output FS.WriteMode \h ->
+    hPutStrLn h wat
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runEff . runFileSystem . readScm

src/Gyehoek/Options.hs

@@ -19,7 +19,6 @@ data Options = MkOptions
   -- , dumpQBE :: Maybe FilePath
   dumpCPS :: Bool
   , dumpParsed :: Bool
-  , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
   }
@@ -50,12 +49,10 @@ parseOutput = strOption
 
 parseDumpCPS = switch (long "dump-cps")
 parseDumpParsed = switch (long "dump-parsed")
-parseInspectWasm = switch $ long "inspect-wasm" <> short 'p'
 
 parser :: Parser Options
 parser = MkOptions
   <$> parseDumpCPS
   <*> parseDumpParsed
-  <*> parseInspectWasm
   <*> parseOutput
   <*> argument str (metavar "FILE")

src/Gyehoek/Scheme/Syntax.hs

@@ -52,7 +52,7 @@ import Language.Haskell.TH.Quote (QuasiQuoter)
 
 
 newtype Name = MkName { inner :: Text }
-  deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
+  deriving newtype (Show, Eq, IsString, Gen, Hashable)
   deriving stock (Generic, Data)
 
 getName :: Name -> Text