qq

idk
2026-07-16 03:16:59 -06:00 · 2026-07-15 15:18:25 -06:00 · 2026-07-15 00:27:05 -06:00 · 2026-07-14 17:36:36 -06:00 · 2026-07-14 03:15:35 -06:00 · 2026-07-12 20:58:10 -06:00
84 changed files with 1802 additions and 1829 deletions
@@ -0,0 +1,13 @@
 name: build
 on: [push]
 jobs:
  build:
    runs-on: nixos
    steps:
      - name: Check out repository code
        uses: actions/checkout@v4
      - name: build gyehoek
        run: nix build -L .#gyehoek
      - name: test gyehoek
        run: nix flake check -L
@@ -8,3 +8,4 @@ dist-newstyle
 *.tix
 .direnv
 result
 play/
@@ -1,531 +0,0 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# OPTIONS_GHC -Wno-orphans -Wno-unused-matches -Wno-missing-signatures #-}
 {- HLINT ignore "Avoid lambda using `infix`" -}
 module Gyehoek.ANF.Syntax
  ( Exp(..)
  , toANF
  , lower
  , wrapFunction
  , lowerProgram
  )
  where
 import Data.Text (Text)
 import Effectful
 import Gyehoek.QBE qualified as QBE
 import Data.List (List)
 import Data.Text.IO qualified as TIO
 import Control.Lens
 import Data.Generics.Labels
 import Data.Vector.Strict (Vector)
 import Data.Function (fix)
 import Effectful.Writer.Static.Local
 import Gyehoek.Scheme.Syntax qualified as Lam
 import Gyehoek.Scheme.Syntax (Name, Prim(..), Lit(..))
 import Gyehoek.GenSym
 import Control.Monad.Cont
 import Data.Foldable
 import Data.List.NonEmpty (NonEmpty((:|)))
 import Data.List.NonEmpty qualified as NE
 import Gyehoek.QBE (FuncDef(FuncDef))
 import Data.Foldable1
 import qualified Data.Text as T
 import Data.String (fromString)
 import Language.SexpGrammar as Sexp hiding (List, iso, encode, decode, traversed)
 import Language.SexpGrammar.Generic
 import GHC.Generics (Generic)
 import Gyehoek.Sexp
 import Control.Category
 import Prelude hiding ((.), id)
 import Data.InvertibleGrammar.Base qualified as IG
 import Data.InvertibleGrammar.Base ((:-)((:-)))
 import qualified Gyehoek.Sexp
 import Control.Lens.Unsound
 import qualified Data.Bits
 import qualified GHC.IO.Encoding as T
 import qualified Data.Text.Encoding as T
 data Val
  = ValLit Lit
  | ValVar Name
  deriving (Show, Generic)
 data Exp
  = ExpLetApply Name Val (List Val) Exp
  | ExpLetPrim Name (Prim Val) Exp
  | ExpBegin (List Exp)
  | ExpVal Val
  deriving (Show, Generic)
 expandBindings
  -- | Match constructor. (an affine fold would be preferable to a
  --   prism here)
  :: Prism' e (lhs, rhs, e)
  -> e
  -> (List (lhs, rhs), e)
 expandBindings p = go [] where
  go acc e =
    case e ^? p of
      Just (l,r,e') -> go ((l,r):acc) e'
      Nothing -> (acc, e)
 collapseBindings
  :: Foldable f => AReview e (lhs, rhs, e) -> f (lhs, rhs)
  -> e -> e
 collapseBindings p bs e = foldr (\(l,r) e' -> p # (l,r,e')) e bs
 -- | Technically unlawful.
 bindingTelescope
  :: Prism' e (lhs, rhs, e)
  -> Iso' e (List (lhs, rhs), e)
 bindingTelescope p = iso
  (expandBindings p)
  (uncurry $ collapseBindings p)
 foldLet
  :: Prism' Exp (lhs, rhs, Exp)
  -> Grammar
       Position
       (Exp :- NonEmpty (lhs, rhs) :- t)
       (Exp :- rhs :- lhs :- t)
 foldLet p =
  IG.Iso
    (\(e :- ((l1,r1):|bs) :- t) ->
       collapseBindings p bs e :- r1 :- l1 :- t)
    (\(e :- r :- l :- t) ->
       let (bs,e') = expandBindings p e
       in e' :- ((l,r) :| bs) :- t)
 instance SexpIso Val where
  sexpIso = match
    $ With (. sexpIso)
    $ With (. symbol)
    $ End
 nonEmptyIso :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b)
 nonEmptyIso = iso (\(x:|xs) -> (x,xs)) (uncurry (:|))
 -- nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
 -- nonEmptyGrammar = IG.Iso
 --   (\((x:|xs) :- t) -> xs :- x :- t)
 --   (\(xs :- x :- t) -> (x:|xs) :- t)
 instance SexpIso Exp where
  sexpIso = match
    $ With (. letapp)
    $ With (. letprim)
    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
    $ With (. sexpIso)
    $ End
    where
      letprim
        :: Grammar Position (Sexp :- t) (Exp :- (Prim Val :- (Text :- t)))
      letprim =
        Gyehoek.Sexp.let_ symbol (sexpIso @(Prim Val)) (sexpIso @Exp)
        >>> foldLet #ExpLetPrim
      letapp :: Grammar
        Position (Sexp :- t) (Exp :- List Val :- Val :- Text :- t)
      letapp =
        Gyehoek.Sexp.let_ symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp)
         >>> foldLet (#ExpLetApply
                      . iso (\(rhs,f,xs,e) -> (rhs, f:|xs, e))
                            (\(rhs,f:|xs,e) -> (rhs,f,xs,e)))
         >>> onTail nonEmptyGrammar
 -- 뻘짓이어라
 telescope :: Traversable t => t ((a -> r) -> r) -> (t a -> r) -> r
 telescope = runCont . traverse cont
 toANF'
  :: forall es. GenSym :> es
  => Lam.Exp
  -> (Val -> Eff es Exp)
  -> Eff es Exp
 toANF' (Lam.ExpLit v) k = k . ValLit $ v
 toANF' (Lam.ExpPrim p) k =
  telescope (toANF' <$> p) \p' -> do
    r <- gensym
    ExpLetPrim r p' <$> k (ValVar r)
 toANF' (Lam.ExpApply f xs) k =
  telescope (toANF' <$> (f:|xs)) \(f':|xs') -> do
    r <- gensym
    ExpLetApply r f' xs' <$> k (ValVar r)
 toANF' (Lam.ExpBegin xs) k = ExpBegin <$> traverse anf xs
  where
    anf x = toANF' x (pure . ExpVal)
 toANF' (Lam.ExpLet xs e) k = _
 toANF' e k = _
 toANF e = toANF' e (pure . ExpVal)
 expr =
  Lam.ExpPrim
    (PrimAdd
     (Lam.ExpPrim
      (PrimMul
       (Lam.ExpLit (LitInt 2))
       (Lam.ExpLit (LitInt 3))))
    (Lam.ExpLit (LitInt 4)))
 expr2 =
  Lam.ExpBegin
    [ Lam.ExpPrim
      (PrimWrite
       (Lam.ExpPrim
         (PrimCons
          (Lam.ExpLit (LitInt 2))
          (Lam.ExpLit (LitInt 3)))))
    , Lam.ExpPrim
      (PrimWrite
       (Lam.ExpPrim
        (PrimMul
         (Lam.ExpLit (LitInt 5))
         (Lam.ExpLit (LitInt 4)))))
    ]
 instance Semigroup QBE.Program where
  QBE.Program ts ds fs <> QBE.Program ts' ds' fs' =
    QBE.Program (ts <> ts') (ds <> ds') (fs <> fs')
 instance Monoid QBE.Program where
  mempty :: QBE.Program
  mempty = QBE.Program mempty mempty mempty
 funcdef
  :: QBE.Ident QBE.Global
  -> List QBE.Param -> NonEmpty QBE.Block -> FuncDef
 funcdef name ps =
  QBE.FuncDef
  mempty
  (Just (QBE.AbiBaseTy QBE.Long))
  name Nothing ps QBE.NoVariadic
 prims :: QBE.Program
 prims = QBE.Program primtys mempty primfns where
  primtys =
    [ QBE.TypeDef "scm" Nothing
      [ (QBE.SubExtTy (QBE.BaseTy QBE.Long), Just 2) ]
    ]
  primfns = [ -- write
            -- , mkArith "plus" QBE.Add
            -- , mkArith "star" QBE.Mul
            -- , mkArith "_" QBE.Sub
            -- , mkArith "slash" (QBE.Div QBE.Signed)
            ]
  mkArith name bop =
    funcdef name
    [ QBE.Param (QBE.AbiBaseTy QBE.Long) "x"
    , QBE.Param (QBE.AbiBaseTy QBE.Long) "y"
    ]
    [ QBE.Block "start" []
      [ QBE.BinaryOp ("r" QBE.:= QBE.Long) bop
        (QBE.ValTemporary "x") (QBE.ValTemporary "y")
      ]
      (QBE.Ret (Just (QBE.ValTemporary "r")))
    ]
 data BlockBuilder
  = Emit (Vector QBE.Inst) !BlockBuilder
  | Exit QBE.Jump
  deriving (Show)
 instance Semigroup BlockBuilder where
  Emit a as <> bs = Emit a (as <> bs)
  Exit _ <> bs = bs
 instance Each BlockBuilder BlockBuilder QBE.Inst QBE.Inst where
  each k (Emit is bb) = Emit <$> traverse k is <*> each k bb
  each k (Exit j) = pure (Exit j)
 evalBlockBuilder :: BlockBuilder -> (Vector QBE.Inst, QBE.Jump)
 evalBlockBuilder (Emit is bb) = evalBlockBuilder bb & _1 <>:~ is
 evalBlockBuilder (Exit j)     = ([],j)
 buildBlock :: QBE.Ident QBE.Label -> BlockBuilder -> QBE.Block
 buildBlock n bb = QBE.Block n [] (is ^.. each) j
  where (is,j) = evalBlockBuilder bb
 lowerName :: Name -> QBE.Ident t
 lowerName = fromString . T.unpack
 lowerInt' = QBE.ValConst . QBE.CInt . fromIntegral
 lowerInt = QBE.ValConst . QBE.CInt
  . (Data.Bits..|. 2)
  . (Data.Bits..<<. 2)
  . fromIntegral
 lowerVal
  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
  => Val
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder
 lowerVal (ValLit (LitInt n)) k = k . lowerInt $ n
 -- lowerVal (ValLit (LitQuote (SexpSymbol s))) k = _aaa
 lowerVal (ValLit (LitString s)) k = do
  rawString <- gensym
  r <- gensym
  let bs = T.encodeUtf8 s
      len = lengthOf each bs
  tell . pure $
    QBE.DataDef [] rawString Nothing
      [QBE.FieldExtTy QBE.Byte [QBE.String bs]]
  Emit (alloc r rawString len) <$> k (QBE.ValTemporary r)
  where
    alloc r rs len =
      [ QBE.Call
        (Just (r, QBE.AbiBaseTy QBE.Long))
        (QBE.ValGlobal "scm_from_utf8_string")
        Nothing
        [ QBE.Arg (QBE.AbiBaseTy QBE.Long) (QBE.ValGlobal rs)
        -- N.b. The C function declares this argument as size_t, which
        -- /is/ long on my system.
        , QBE.Arg (QBE.AbiBaseTy QBE.Long) (lowerInt' len)
        ]
        []
      ]
 lowerVal (ValLit _) k = error "todo"
 lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
 binaryPrim :: Prism' (Prim a) (QBE.BinaryOp, a, a)
 binaryPrim = prism' up down where
  up (bop,a,b) = case bop of
    QBE.Add -> _
    QBE.Mul -> _
    _ -> _
  down = \case
    PrimAdd a b -> Just (QBE.Add,a,b)
    PrimMul a b -> Just (QBE.Mul,a,b)
    _ -> Nothing
 lowerArithmetic :: QBE.Assignment -> Prim QBE.Val -> QBE.Inst
 lowerArithmetic r p = QBE.BinaryOp r bop x y
  where
    (bop,x,y) = case p of
      PrimAdd a b -> (QBE.Add,a,b)
      PrimMul a b -> (QBE.Mul,a,b)
      _ -> _
 sizeofScm :: Integral a => a
 sizeofScm = 8
 lowerCons
  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
  => Name -> QBE.Val -> QBE.Val -> Exp
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder
 lowerCons r car cdr e k = do
  r1 <- gensym
  Emit (alloc <> initialise r1) <$> lower' e k
  where
    alloc = [ QBE.Call
              (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
              (QBE.ValGlobal "GC_malloc")
              Nothing
              [ QBE.Arg
                (QBE.AbiBaseTy QBE.Long)
                (QBE.ValConst (QBE.CInt (sizeofScm * 2))) ]
              []
            ]
    initialise r1 =
      [ QBE.BinaryOp (r1 QBE.:= QBE.Long) QBE.Add
        (QBE.ValTemporary (lowerName r)) (QBE.ValConst (QBE.CInt 8))
      , QBE.Store (QBE.BaseTy QBE.Long) car (QBE.ValTemporary (lowerName r))
      , QBE.Store (QBE.BaseTy QBE.Long) cdr (QBE.ValTemporary r1)
      ]
 smallIntHelper'
  :: GenSym :> es
  => QBE.Ident 'QBE.Temporary
  -> QBE.BinaryOp
  -> QBE.Val -> QBE.Val
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder
 smallIntHelper' r bop v1 v2 k = do
  Emit [ QBE.BinaryOp (r QBE.:= QBE.Long)
         bop v1 v2 ]
    <$> k (QBE.ValTemporary r)
 smallIntHelper
  :: GenSym :> es
  => QBE.BinaryOp
  -> QBE.Val -> QBE.Val
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder
 smallIntHelper bop a b k = do
  r <- gensym
  smallIntHelper' r bop a b k
 makeSmallInt'
  :: forall es. (GenSym :> es)
  => QBE.Ident 'QBE.Temporary
  -> QBE.Val
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder
 makeSmallInt' r n k =
  smallIntHelper QBE.Shl n (lowerInt' 2) \n' ->
    smallIntHelper' r QBE.Add n' (lowerInt' 2) k
 makeSmallInt
  :: forall es. (GenSym :> es)
  => QBE.Val
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder
 makeSmallInt n k = do
  r <- gensym
  makeSmallInt' r n k
 getSmallInt
  :: forall es. (GenSym :> es)
  => QBE.Val
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder
 getSmallInt n = smallIntHelper QBE.Shr n (lowerInt' 2)
 lowerWrite 
  :: forall es. (GenSym :> es)
  => Name -> QBE.Val -> Exp
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder
 lowerWrite r x e k =
  Emit [ QBE.Call (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
         (QBE.ValGlobal "scm_write") Nothing
         [QBE.Arg (QBE.AbiBaseTy QBE.Long) x]
         []
       ]
    <$> k (QBE.ValTemporary (lowerName r))
 smallIntMask :: Integer
 smallIntMask = 2 ^ (sizeofScm * 8) - 2
 lowerCar
  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
  => Name -> QBE.Val -> _
  -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
 lowerCar r x e k = do
  Emit [ QBE.Load (lowerName r QBE.:= QBE.Long) QBE.Long x
       ]
    <$> lower' e k
 lowerCdr
  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
  => Name -> QBE.Val -> Exp
  -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
 lowerCdr r x e k = do
  x1 <- gensym
  Emit [ QBE.BinaryOp (x1 QBE.:= QBE.Long)
         QBE.Add x (lowerInt' sizeofScm)
       , QBE.Load (lowerName r QBE.:= QBE.Long) QBE.Long
         (QBE.ValTemporary x1)
       ]
    <$> lower' e k
 lowerPrim 
  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
  => Name -> Prim Val -> Exp
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder
 lowerPrim r p e k =
  telescope (lowerVal <$> p) \case
    (preview binaryPrim -> Just (bop,a,b)) ->
      getSmallInt a \a' ->
        getSmallInt b \b' ->
          smallIntHelper bop a' b' \c ->
            makeSmallInt' (lowerName r) c \_ ->
              lower' e k
    PrimCons x y -> lowerCons r x y e k
    PrimCar x -> lowerCar r x e k
    PrimCdr x -> lowerCdr r x e k
    PrimWrite x -> lowerWrite r x e k
 lower'
  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
  => Exp
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder
 lower' (ExpVal v) k = lowerVal v k
 lower' (ExpLetPrim r p e) k = lowerPrim r p e k
 lower' (ExpLetApply r f xs e) k =
  telescope (lowerVal @es <$> (f:|xs)) \(f':|xs') ->
    Emit [ QBE.Call
            (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
            f'
            Nothing
            (QBE.Arg (QBE.AbiBaseTy QBE.Long) <$> xs')
            []
          ]
      <$> lower' e k
 lower' (ExpBegin (x:xs)) k = fold1 <$> traverse low (x:|xs)
  where low e = lower' @es e (pure . Exit . QBE.Ret . Just)
 lower' _ k = _
 lower
  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
  => QBE.Ident QBE.Label
  -> Exp
  -> Eff es QBE.Block
 lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
 lowerProgram 
  :: (GenSym :> es, Traversable t)
  => t Exp -> Eff es QBE.Program
 lowerProgram anfs =
  case toList anfs of
    -- hack for dev convenience: if there's only one expression, let
    -- it be the entry point.
    [e] -> do
      (b,dataDefs) <- runWriter . lower "start" $ e
      let f = wrapFunction @NonEmpty "main" [b]
      pure $ QBE.Program [] (dataDefs ^.. each) [f]
    _ -> do
      let low e = do
            bl <- gensym' "b"
            fl <- gensym' "f"
            b <- lower bl e
            pure $ wrapFunction @NonEmpty fl [b]
      (fs,dataDefs) <- runWriter $ traverse low anfs
      pure $ QBE.Program [] (dataDefs ^.. each) (fs ^.. traversed)
 wrapFunction
  :: Foldable1 t
  => QBE.Ident 'QBE.Global -> t QBE.Block -> QBE.FuncDef
 wrapFunction l bs =
  QBE.FuncDef [QBE.Export]
    (Just (QBE.AbiBaseTy QBE.Word))
    l Nothing [] QBE.NoVariadic (toNonEmpty bs)
 wrapProgram :: Foldable1 t => t QBE.Block -> QBE.Program
 wrapProgram bs = prims <> QBE.Program [] [] [main] where
  main = QBE.FuncDef [QBE.Export]
    (Just (QBE.AbiBaseTy QBE.Word))
    "main" Nothing [] QBE.NoVariadic (toNonEmpty bs)
@@ -1,61 +0,0 @@
 {-# LANGUAGE RequiredTypeArguments #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
 module Gyehoek.QBE
  ( module QBE
  , render
  , fn
  , writeTo
  )
  where
 import Gyehoek.QBE.Parse
 import Language.QBE as QBE
 import Data.String (IsString(fromString))
 import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
 import Data.Text (Text)
 import Data.Data
 import Prettyprinter.Render.Text (renderStrict)
 import Text.Megaparsec
 import Text.Megaparsec.Char
 import Language.Haskell.TH qualified as TH
 import Language.Haskell.TH.Quote
 import Data.Kind (Type)
 import qualified Data.Text.IO as TIO
 writeTo :: FilePath -> Text -> IO ()
 writeTo = TIO.writeFile
 render :: Pretty a => a -> Text
 render = renderStrict . layoutPretty defaultLayoutOptions . pretty
 parseQuoteExp
  :: (TH.Quote m, MonadFail m, Data a) => P a -> String -> m TH.Exp
 parseQuoteExp p s =
  case parse (space *> p <* space <* eof) "qq" (fromString s) of
    Left es -> fail . foldMap f . bundleErrors $ es
      where f e = parseErrorPretty e ++ "\n\n"
    Right x -> dataToExpQ (\_ -> Nothing) x
 -- quoteExp :: TH.Quote m => forall (t :: Type) -> (Parser t) => String -> m TH.Exp
 -- quoteExp t s = case parse (parser @t) "qq" (fromString s) of
 --   Left es -> _
 --   Right x -> dataToExpQ (\_ -> Nothing) x
 makeQQ :: forall (t :: Type) -> Parser t => QuasiQuoter
 makeQQ t = QuasiQuoter
  { quoteExp = parseQuoteExp (parser @t)
  , quotePat = _
  , quoteType = undefined
  , quoteDec = undefined
  }
 fn :: QuasiQuoter
 fn = makeQQ (type FuncDef)
@@ -1,194 +0,0 @@
 {-# LANGUAGE RequiredTypeArguments #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 module Gyehoek.QBE.Parse where
 import Language.QBE as QBE
 import Effectful.State.Dynamic
 import Effectful.Dispatch.Dynamic
 import Effectful
 import Numeric.Natural
 import Data.String (IsString(fromString))
 import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
 import Data.Text (Text)
 import Data.Data
 import Prettyprinter.Render.Text (renderStrict)
 import Text.Megaparsec
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer qualified as L
 import Data.Void (Void)
 import Data.Char (isAlpha, isAlphaNum)
 import Control.Lens.Wrapped
 import Data.Functor.Contravariant (Predicate(Predicate))
 import qualified Data.Text as T
 import Data.Functor
 import Data.List (List)
 import Data.Foldable (fold)
 import Data.Maybe (isJust, fromMaybe)
 import Control.Monad.Fix (MonadFix(mfix))
 import Data.List.NonEmpty (fromList)
 import Language.Haskell.TH qualified as TH
 import Language.Haskell.TH.Quote
 import Data.Proxy
 import Data.Kind (Type)
 type P = Parsec Void Text
 sc :: P ()
 sc = L.space hspace1 (L.skipLineComment "#") empty
 lexeme :: P a -> P a
 lexeme = L.lexeme sc
 symbol :: Text -> P Text
 symbol = L.symbol sc
 infixr 8 .:
 (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
 (.:) f g x y = f (g x y)
 rawIdent :: P QBE.RawIdent
 rawIdent = (fromString .: (:) <$> lead <*> trail) <?> "ident"
  where
    lead = satisfy \x -> isAlpha x || (x=='.') || (x=='_')
    trail = fmap T.unpack . takeWhileP Nothing $ \x ->
      isAlphaNum x || (x=='.') || (x=='_')
 class ParseIdent (s :: Sigil) where
  ident :: P (QBE.Ident s)
 rawIdentWithSigil :: Char -> P (Ident t)
 rawIdentWithSigil c = Ident <$> lexeme (char c *> rawIdent)
 instance ParseIdent AggregateTy where ident = rawIdentWithSigil ':'
 instance ParseIdent Global      where ident = rawIdentWithSigil '$'
 instance ParseIdent Temporary   where ident = rawIdentWithSigil '%'
 instance ParseIdent QBE.Label   where ident = rawIdentWithSigil '@'
 const :: P QBE.Const
 const = cint <|> csingle <|> cdouble <|> cglobal <?> "const"
  where
    cint = CInt <$> lexeme (L.signed empty L.decimal) <?> "integer"
    csingle = empty <?> "single-precision float"
    cdouble = empty <?> "double-precision float"
    cglobal = CGlobal <$> ident <?> "global symbol"
 val :: P QBE.Val
 val = vconst <|> vtemp <?> "val"
  where
    vconst = ValConst <$> Gyehoek.QBE.Parse.const
    vtemp = ValTemporary <$> ident <?> "temporary symbol"
 assignment :: P QBE.Assignment
 assignment =
  Assignment <$> ident <*> (char '=' *> basety)
 basety :: P QBE.BaseTy
 basety = lexeme $ char 'w' $> Word
              <|> char 'l' $> Long
              <|> char 's' $> Single
              <|> char 'd' $> Double
 abity :: P AbiTy
 abity = AbiBaseTy <$> basety
    <|> AbiAggregateTy <$> ident
 binaryOp :: P QBE.BinaryOp
 binaryOp = lexeme $ "add" $> Add
                <|> "sub" $> Sub
                <|> "mul" $> Mul
                <|> "div" $> Div Signed
 comma :: P a -> P a
 comma p = symbol "," *> p
 inst :: P QBE.Inst
 inst = try binaryOpInst <|> negInst <?> "inst"
  where
    binaryOpInst =
      BinaryOp
        <$> assignment
        <*> binaryOp
        <*> val <*> comma val
    negInst = Neg <$> assignment <*> (symbol "neg" *> val)
 jump :: P QBE.Jump
 jump = jmp <|> jnz <|> ret <|> hlt <?> "jump"
  where
    jmp = symbol "jmp" *> (Jmp <$> ident)
    jnz = symbol "jnz" *> (Jnz <$> val <*> ident <*> comma ident)
    ret = symbol "ret" *> (Ret <$> optional val)
    hlt = empty
 nl :: P ()
 nl = void (some (newline *> sc)) <?> "newline"
 phi :: P QBE.Phi
 phi = empty
 block :: P QBE.Block
 block = Block
  <$> (ident <* nl)
  <*> sepBy phi nl
  <*> sepBy inst nl
  <*> jump
 sepByTry :: MonadParsec e s m => m a -> m sep -> m (List a)
 sepByTry p sep = do
  x <- p
  xs <- many (try $ sep *> p)
  pure (x:xs)
 paramList :: P (Maybe (Ident Temporary), List Param, Variadic)
 paramList = label "parameter list" $ between (symbol "(") (symbol ")") do
  e <- optional env
  ps <- optional . try $ do
    commaIf (isJust e)
    sepByTry reg (symbol ",")
  v <- optional do
    commaIf (isJust e || isJust ps)
    variadic
  pure (e, fromMaybe [] ps, fromMaybe NoVariadic v)
  where
    commaIf True = void $ symbol ","
    commaIf False = pure ()
    env = symbol "env" *> ident @Temporary <?> "environment parameter"
    reg = Param <$> abity <*> ident <?> "regular parameter"
    variadic = symbol "..." $> Variadic <?> "variadic parameter"
 funcdef :: P QBE.FuncDef
 funcdef = do
  linkages <- many linkage
  symbol "function"
  returnTy <- optional abity
  name <- ident @Global
  (env,params,variadic) <- paramList
  code <- fmap fromList . between (symbol "{" *> nl) (symbol "}") $
    sepEndBy1 block nl
  pure $ FuncDef linkages returnTy name env params variadic code
 linkage :: P Linkage
 linkage = symbol "export" $> Export
 -- stripped :: P a -> P a
 -- stripped p = optional nl *>
 class Data a => Parser a where
  parser :: P a
 instance Parser FuncDef where parser = funcdef
 class ParseSeparator a where
  parseSeparator :: Proxy a -> P ()
 instance (Parser a, ParseSeparator a) => Parser (List a) where
  parser = sepBy parser (parseSeparator @a Proxy)
 instance ParseSeparator FuncDef where parseSeparator _ = nl
 instance ParseSeparator Block where parseSeparator _ = nl
@@ -1,142 +0,0 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 module Gyehoek.Scheme.Syntax
  ( Name
  , Prim(..)
  , Lit(..)
  , Define(..)
  , Exp(..)
  , Sexp(..)
  )
  where
 import Data.Text (Text)
 import Data.List (List)
 import Language.SexpGrammar
  ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
 import Language.SexpGrammar qualified as Sexp
 import Language.SexpGrammar.Generic
 import GHC.Generics
 import Prelude hiding ((.), id)
 import Control.Category
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Gyehoek.Sexp qualified
 import Control.Lens (Each)
 type Name = Text
 data Prim e
  = PrimAdd e e
  | PrimSub e e
  | PrimMul e e
  | PrimDiv e e
  | PrimCons e e
  | PrimCar e
  | PrimCdr e
  | PrimImmediateP e
  | PrimConsP e
  | PrimIntegerP e
  | PrimWrite e
  deriving (Show, Generic, Functor, Foldable, Traversable)
 instance Each (Prim e) (Prim e') e e'
 data Lit
  = LitInt Int
  | LitNil
  | LitBool Bool
  | LitString Text
  | LitQuote Sexp
  deriving (Show, Generic)
 data Define
  = DefineConstant Name Exp
  | DefineProcedure 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
  | ExpVar Name
  | ExpApply Exp (List Exp)
  deriving (Show, Generic)
 data Sexp
  = SexpCons Sexp Sexp
  | SexpSymbol Text
  | SexpLit Lit
  deriving (Show, Generic)
 instance SexpIso a => SexpIso (Prim a) where
  sexpIso = match
    $ With (. binop "+")
    $ With (. binop "-")
    $ With (. binop "*")
    $ With (. binop "/")
    $ With (. binop "cons")
    $ With (. unop "car")
    $ With (. unop "cdr")
    $ With (. unop "immediate?")
    $ With (. unop "cons?")
    $ With (. unop "integer?")
    $ With (. unop "write")
    $ End
    where
      primname = ("prim:" <>)
      unop s = list $ el (sym (primname s)) >>> el sexpIso
      binop s = list $ el (sym (primname s)) >>> el sexpIso >>> el sexpIso
 instance SexpIso Lit where
  sexpIso = match
    $ With (. sexpIso)
    $ With (. sym "nil")
    $ With (. sexpIso)
    $ With (. sexpIso)
    $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
    $ End
 instance SexpIso Sexp where
  sexpIso = match
    $ With (\cons -> cons . Gyehoek.Sexp.todo)
    $ With (\s -> s . symbol)
    $ With (\lit -> lit . sexpIso)
    $ End
 instance SexpIso Define where
  sexpIso = match
    $ With (. defconst)
    $ With (. defun)
    $ End
    where
      defconst = list $ el (sym "define") >>> el symbol >>> el sexpIso
      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
      args = list $ el symbol >>> rest symbol
 instance SexpIso Exp where
  sexpIso = match
    $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
    $ With (. sexpIso)
    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
    $ With (. sexpIso)
    $ With (. if_)
    $ With (. sexpIso)
    $ With (. lam)
    $ With (. symbol)
    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
    $ End
    where
      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
      lam = list
        ( el (sym "lambda")
          >>> el (sexpIso @(List Name))
          >>> el sexpIso )
@@ -1,111 +0,0 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLabels #-}
 module Gyehoek.Sexp
  ( let_
  , sexp
  , nonempty
  , nonEmptyGrammar
  , encode
  , decode
  , parseSexps
  , prefixSugar
  , todo
  )
 where
 import Data.Text (Text)
 import Language.SexpGrammar as Sexp hiding (List, encode, decode, iso)
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp qualified as S
 import Language.SexpGrammar.Generic
 import Data.InvertibleGrammar.Base qualified as IGB
 import Data.InvertibleGrammar qualified as IG
 import Data.InvertibleGrammar.Base ((:-)((:-)))
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.List (List)
 import Data.Text.Encoding
 import Data.Either (either)
 import GHC.Generics (Generic)
 import Control.Lens
 import Data.Generics.Labels
 import System.Process
 import GHC.IO.Unsafe (unsafePerformIO)
 import qualified Data.Text.IO as TIO
 import Control.Monad (join)
 import qualified Language.Sexp.Located as SexpLoc
 import Data.Void (absurd)
 sexp :: SexpIso a => Iso' a Text
 sexp = iso
  (either error id . encode)
  (either error id . decode)
 encode :: SexpIso a => a -> Either String Text
 encode = (_Right %~ decodeUtf8 . view strict) . Sexp.encode
 decode :: SexpIso a => Text -> Either String a
 decode = Sexp.decode . view lazy . encodeUtf8
 parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
 parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
  where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
 nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
 nonEmptyGrammar = IGB.Iso
  (\((x:|xs) :- t) -> reverse xs :- x :- t)
  (\(xs :- x :- t) -> (x :| reverse xs) :- t)
 nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
 nonempty a =
  list (el a >>> rest a) >>>
    IG.flipped nonEmptyGrammar
 let_
  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
  -> (forall t. Grammar Position (Sexp :- t) (b :- t))
  -> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
  -> Grammar Position (Sexp :- t1) t2
 let_ name rhs e = list (el (sym "let") >>> el bindings >>> el e)
  where
    -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
    bindings = nonempty binding
    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
    binding = list (el name >>> el rhs) >>> pair
 data DotList a = MkDotList (NonEmpty a) a
  deriving (Show, Generic)
 dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
 dotlist x = list $ rest $ coproduct
  [ x >>> _
  ]
 -- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
 prefixSugar
  :: Text -> Prefix
  -> Grammar Position (Sexp :- t') a
  -> Grammar Position (Sexp :- t') a
 prefixSugar name prefix e = coproduct
  -- 'something
  [ Sexp.prefixed prefix e
  -- (quote something)
  , list $ el (sym name) >>> el e
  ]
 todo :: Grammar p (Sexp :- t) t'
 todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
  where
    f _ = Left $ unexpected "todo"
    g _ = Left $ unexpected "todo"
 lambda
  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
  -> Grammar Position (Sexp :- List a :- t1) t2
  -> Grammar Position (Sexp :- t1) t2
 lambda name e = list $
  el (sym "lambda")
  >>> el (list $ rest name)
  >>> el e
@@ -1,124 +1,6 @@
-{-# LANGUAGE OverloadedLabels #-}
+module Main (main) where
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ViewPatterns #-}
 module Main
  (main)
  where
-import qualified Gyehoek.ANF.Syntax as ANF
+import Gyehoek.Driver qualified
 import Gyehoek.QBE (render)
 import Gyehoek.Options
 import qualified Data.Text.IO as TIO
 import Data.Text (Text)
 import Prelude hiding (readFile, (.),id)
 import Control.Category
 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 Gyehoek.QBE as QBE
 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
-main :: IO ()
+main = Gyehoek.Driver.main
 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
 readScm :: FileSystem :> es => FilePath -> Eff es (List Scm.Exp)
 readScm f = (Sexp.parseSexps f <$> readFile f) >>= either error pure
 toANF
  :: (GenSym :> es, FileSystem :> es)
  => FilePath -> List Scm.Exp -> Eff es (List ANF.Exp)
 toANF f exps = do
  anfs <- traverse ANF.toANF exps
  case traverse Sexp.encode anfs of
    Left e -> hPutStr FS.stderr (view packed e)
    Right ss -> do
      let anf_file = f -<.> "anf"
      FS.withFile anf_file FS.WriteMode \h_anf -> do
        hPutStr h_anf ";;; -*- mode:scheme -*-\n\n"
        hPutStr h_anf $ foldr (\x y -> x <> "\n\n" <> y) "" ss
      hPutStrLn FS.stderr $ "wrote " <> T.pack anf_file
  pure anfs
 toQBE
  :: (GenSym :> es, FileSystem :> es, Traversable t)
  => FilePath -> t ANF.Exp -> Eff es QBE.Program
 toQBE f anfs = do
  p <- ANF.lowerProgram anfs
  let qbe_file = f -<.> "ssa"
  FS.withFile qbe_file FS.WriteMode \h -> do
    hPutStr h . render $ p
  hPutStrLn FS.stderr $ "wrote " <> T.pack qbe_file
  pure p
 callQBE
  :: (GenSym :> es, FileSystem :> es, IOE :> es)
  => FilePath -> Eff es FilePath
 callQBE f = do
  let asm_file = f -<.> "s"
      qbe_file = f -<.> "ssa"
  C.StdoutUntrimmed stdout <-
    C.run $ C.cmd "qbe" & C.addArgs [qbe_file]
  FS.withFile asm_file FS.WriteMode \h -> do
    hPutStr h stdout
  hPutStrLn FS.stderr $ "wrote " <> T.pack asm_file
  pure asm_file
 callGCC
  :: (GenSym :> es, FileSystem :> es, IOE :> es)
  => FilePath -> List String -> Eff es FilePath
 callGCC f args = do
  let asm_file = f -<.> "s"
      exe = dropExtension f
  C.StdoutTrimmed (T.words -> flags) <-
    C.run $ C.cmd "pkg-config"
          & C.addArgs @String ["--cflags", "--libs", "bdw-gc"]
  C.run_ $ C.cmd "cc"
         & C.addArgs flags
         & C.addArgs ["-o", exe, asm_file]
         & C.addArgs args
  hPutStrLn FS.stderr $ "wrote " <> T.pack exe
  pure exe
 driver
  :: (GenSym :> es, FileSystem :> es, IOE :> es)
  => Options -> Eff es ()
 driver = runGenSym . traverseOf_ (#sourceFiles . folded) \f -> do
  exps <- readScm f
  anfs <- toANF f exps
  qbe <- toQBE f anfs
  callQBE f
  callGCC f ["../runtime/target/debug/libgyehoek.a"]
  pure ()
@@ -1,4 +1,5 @@
 packages: *.cabal
 tests: True
 source-repository-package
    type: git
@@ -0,0 +1,17 @@
 #+title: representation of Scheme types
 the Scheme unitype is encoded as ~(ref eq)~ with immediates in ~(ref i31)~ and heap objects in ~$heap-object~:
 #+begin_src wat
  (type $heap-object (sub (struct (field $hash (mut i32)))))
 #+end_src
 * immediates
 all immediates are stored in ~(ref i31)~ and thus must fit in 31 bits. the most important immediate, the integer, is indicated by a null low bit.
 #+begin_example
 XXXX XXXX XXXX XXXX XXXX XXXX XXXX XX00
                                     || 
                                     |\ used by wasm's i31 rep
      zero indicates a 30-bit fixnum /
      in the upper bits
 #+end_example
@@ -1,4 +0,0 @@
 ;;; -*- mode:scheme -*-
 (let ((x0 (prim:write "wawa"))) x0)
@@ -1,23 +0,0 @@
 .data
 .balign 8
 .1:
 	.ascii "wawa"
 /* end data */
 .text
 .globl main
 main:
 	pushq %rbp
 	movq %rsp, %rbp
 	movl $4, %esi
 	leaq .1(%rip), %rdi
 	callq scm_from_utf8_string
 	movq %rax, %rdi
 	callq scm_write
 	leave
 	ret
 .type main, @function
 .size main, .-main
 /* end function main */
 .section .note.GNU-stack,"",@progbits
@@ -1 +0,0 @@
 (prim:write "wawa")
@@ -1,10 +0,0 @@
 data $.1 =
 {b "wawa"}
 export
 function w $main () {
@start
    %.2 =l call $scm_from_utf8_string (l $.1, l 4)
    %x0 =l call $scm_write (l %.2)
    ret %x0
 }
@@ -1,4 +0,0 @@
 ;;; -*- mode:scheme -*-
 (let ((x0 (prim:cons 4 5)) (x1 (prim:write x0))) x1)
@@ -1,18 +0,0 @@
 .text
 .globl main
 main:
 	pushq %rbp
 	movq %rsp, %rbp
 	movl $16, %edi
 	callq GC_malloc
 	movq %rax, %rdi
 	movq $18, (%rdi)
 	movq $22, 8(%rdi)
 	callq scm_write
 	leave
 	ret
 .type main, @function
 .size main, .-main
 /* end function main */
 .section .note.GNU-stack,"",@progbits
@@ -1 +0,0 @@
 (prim:write (prim:cons 4 5))
@@ -1,10 +0,0 @@
 export
 function w $main () {
@start
    %x0 =l call $GC_malloc (l 16)
    %.2 =l add %x0, 8
    storel 18, %x0
    storel 22, %.2
    %x1 =l call $scm_write (l %x0)
    ret %x1
 }
@@ -1,15 +0,0 @@
 (define (adder x)
  (lambda (y)
    (+ x y)))
 ((adder 3) 4)
 (define (adder x)
  (list (lambda (self y)
          (+ (nth self 1) y))
        x))
 (let ((closure (adder 3)))
  ((nth closure 0) closure 4))
@@ -1,70 +0,0 @@
 .text
 zerop:
 	pushq %rbp
 	movq %rsp, %rbp
 	cmpl $0, %edi
 	jnz .Lbb2
 	movl $1, %eax
 	jmp .Lbb3
 .Lbb2:
 	movl $0, %eax
 .Lbb3:
 	leave
 	ret
 .type zerop, @function
 .size zerop, .-zerop
 /* end function zerop */
 .text
 factorial:
 	pushq %rbp
 	movq %rsp, %rbp
 	subq $8, %rsp
 	pushq %rbx
 	movq %rdi, %rbx
 	callq zerop
 	movq %rbx, %rdi
 	cmpl $0, %eax
 	jnz .Lbb6
 	movq %rdi, %rbx
 	subq $1, %rdi
 	callq factorial
 	movq %rbx, %rdi
 	imulq %rdi, %rax
 	jmp .Lbb7
 .Lbb6:
 	movl $1, %eax
 .Lbb7:
 	popq %rbx
 	leave
 	ret
 .type factorial, @function
 .size factorial, .-factorial
 /* end function factorial */
 .data
 .balign 8
 fstr:
 	.ascii "fac 3 = %d\n"
 	.byte 0
 /* end data */
 .text
 .globl main
 main:
 	pushq %rbp
 	movq %rsp, %rbp
 	movl $3, %edi
 	callq factorial
 	movq %rax, %rsi
 	leaq fstr(%rip), %rdi
 	movl $0, %eax
 	callq printf
 	movl $0, %eax
 	leave
 	ret
 .type main, @function
 .size main, .-main
 /* end function main */
 .section .note.GNU-stack,"",@progbits
@@ -1,16 +0,0 @@
 (define (factorial n)
  (if (zero? n)
      1
      (* n (factorial (- n 1)))))
 ;;; ANF
 (define (factorial n)
  (let ((r₁ (zero? n)))
    (if r₁
        1
        (let ((r₂ (- n 1))
              (r₃ (factorial r₂))
              (r₄ (* n r₃)))
          r₄))))
@@ -1,30 +0,0 @@
 function l $zerop (l %n) {
@start
 	jnz %n, @b1, @b2
@b1
 	ret 0
@b2
 	ret 1
 }
 function l $factorial (l %n) {
@start
 	%r1 =l call $zerop (l %n)
 	jnz %r1, @b1, @b2
@b1
 	ret 1
@b2
 	%r2 =l sub %n, 1
 	%r3 =l call $factorial (l %r2)
 	%r4 =l mul %n, %r3
 	ret %r4
 }
 data $fstr = { b "fac 3 = %d\n", b 0 }
 export function w $main () {
@start
 	%r =l call $factorial (l 3)
 	call $printf (l $fstr, ..., l %r)
 	ret 0
 }
@@ -1,4 +0,0 @@
 ;;; -*- mode:scheme -*-
 (let ((x0 (prim:write "안녕하세요"))) x0)
@@ -1,23 +0,0 @@
 .data
 .balign 8
 .1:
 	.ascii "\354\225\210\353\205\225\355\225\230\354\204\270\354\232\224"
 /* end data */
 .text
 .globl main
 main:
 	pushq %rbp
 	movq %rsp, %rbp
 	movl $15, %esi
 	leaq .1(%rip), %rdi
 	callq scm_from_utf8_string
 	movq %rax, %rdi
 	callq scm_write
 	leave
 	ret
 .type main, @function
 .size main, .-main
 /* end function main */
 .section .note.GNU-stack,"",@progbits
@@ -1 +0,0 @@
 (prim:write "안녕하세요")
@@ -1,10 +0,0 @@
 data $.1 =
 {b "\354\225\210\353\205\225\355\225\230\354\204\270\354\232\224"}
 export
 function w $main () {
@start
    %.2 =l call $scm_from_utf8_string (l $.1, l 15)
    %x0 =l call $scm_write (l %.2)
    ret %x0
 }
@@ -16,35 +16,46 @@
        "x86_64-darwin" "x86_64-linux"
      ];
      overlays = [
        haskellNix.overlay
        (final: prev: {
-          inherit (sydpkgs.packages.${final.stdenv.hostPlatform.system})
+          gyehoek-wasmtime-wrapper = final.callPackage ./wasmtime.nix {};
            bdwgc;
        })
        (final: prev: {
          gyehoek = final.haskell-nix.project' {
            src = ./.;
            compiler-nix-name = "ghc912";
            modules = [({ pkgs, lib, ...}: {
              packages.gyehoek.components.tests.test.preCheck =
                let
                  bin = [
                    pkgs.gyehoek-wasmtime-wrapper
                    pkgs.git
                  ];
                in ''
                  # Wasmtime requires a cache in $HOME. This is less
                  # painful than reconfiguring the cache location.
                  export HOME=$(mktemp -d)
                  export PATH=${lib.makeBinPath bin}:$PATH
                '';
            })];
            shell = {
              withHoogle = true;
-              inputsFrom = [
+              inputsFrom = [];
                self.packages.${final.stdenv.hostPlatform.system}.runtime
              ];
              tools = {
                cabal = {};
                haskell-language-server = {};
              };
              buildInputs = with final; [
                gcc
                qbe
                haskellPackages.cabal-fmt
-                bdwgc
+                self.packages.${final.stdenv.hostPlatform.system}.shake
-                pkg-config
+                final.wabt
-                guile
+                final.nodejs
-                clang-tools # clangd
+                final.wasm-tools
-                gdb
+                final.wac-cli
-                gdbgui
+                final.guile
                final.gyehoek-wasmtime-wrapper
              ];
            };
          };
@@ -72,15 +83,18 @@
      _pkgs = each-system ({ pkgs, ... }: pkgs);
      _hf = hf;
-      packages = each-system ({ pkgs, system, ... }:
+      packages = each-system ({ pkgs, lib, system, ... }:
-        hf.packages.${system} // {
+        hf.packages.${system} // lib.fix (packages: {
-          default = hf.packages.${system}."gyehoek:exe:gyehoek";
+          gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
-          runtime = pkgs.callPackage ./runtime {};
+          default = packages.gyehoek;
-          inherit (pkgs) bdwgc;
+          shake = pkgs.callPackage ./shake-wrapper.nix {};
-        });
+        }));
      devShells = each-system
        ({ pkgs, system, ... }: hf.devShells.${system});
      checks = each-system
        ({ pkgs, system, ... }: hf.checks.${system});
    };
  nixConfig = {
@@ -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 >
@@ -0,0 +1,47 @@
 (module
  (type $heap-object (sub (struct (field (mut i32)))))
  (func
    (param)
    (result (ref eq))
    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
    (i32.const 3)
    (i32.const 2)
    i32.shl
    ref.i31
    (ref.cast (ref i31))
    i31.get_s
    (i32.const 4)
    (i32.const 2)
    i32.shl
    ref.i31
    (ref.cast (ref i31))
    i31.get_s
    i32.mul
    ref.i31
    (local.set 0)
    (i32.const 2)
    (i32.const 2)
    i32.shl
    ref.i31
    (ref.cast (ref i31))
    i31.get_s
    (i32.const 5)
    (i32.const 2)
    i32.shl
    ref.i31
    (ref.cast (ref i31))
    i31.get_s
    i32.mul
    ref.i31
    (local.set 1)
    (local.get 0)
    (ref.cast (ref i31))
    i31.get_s
    (local.get 1)
    (ref.cast (ref i31))
    i31.get_s
    i32.add
    ref.i31
    (local.set 2)
    (local.get 2))
  (export "main" (func 0)))
@@ -0,0 +1 @@
 (+ (* 3 4) (* 2 5))
@@ -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 >
@@ -0,0 +1,13 @@
 (module
  (type (sub (struct (field (mut i32)))))
  (func
    (param)
    (result (ref eq))
    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
    (i32.const 0)
    ref.i31
    (if
      (result i32)
      (then (i32.const 777) ref.i31)
      (else (i32.const 555) ref.i31)))
  (export "main" (func 0)))
@@ -0,0 +1 @@
 (if #false 777 555)
@@ -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 >
@@ -0,0 +1,13 @@
 (module
  (type (sub (struct (field (mut i32)))))
  (func
    (param)
    (result (ref eq))
    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
    (i32.const 1)
    ref.i31
    (if
      (result i32)
      (then (i32.const 777) ref.i31)
      (else (i32.const 555) ref.i31)))
  (export "main" (func 0)))
@@ -0,0 +1 @@
 (if #true 777 555)
@@ -0,0 +1 @@
 (λ (x) x)
@@ -0,0 +1 @@
 ((λ (x) (* x x)) 5)
@@ -20,38 +20,55 @@ common ghcstuffs-dev
 common ghcstuffs
  ghc-options:
    -Wall -fdefer-type-errors -fno-show-valid-hole-fits
-    -fdefer-out-of-scope-variables -fplugin=Effectful.Plugin
+    -fdefer-out-of-scope-variables -threaded
    -threaded
  default-extensions:
    BlockArguments
    DeriveGeneric
    OverloadedRecordDot
    OverloadedStrings
    PartialTypeSignatures
    PatternSynonyms
    QuasiQuotes
 executable gyehoek
  import:           ghcstuffs, ghcstuffs-dev
  main-is:          Main.hs
-  -- cabal-fmt: expand app -Main
+  build-depends:
-  other-modules:
+    , base                  ^>=4.21.2.0
-    Gyehoek.ANF.Syntax
+    , 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
    Gyehoek.GenSym
    Gyehoek.Options
    Gyehoek.QBE
    Gyehoek.QBE.Parse
    Gyehoek.Scheme.Syntax
    Gyehoek.Sexp
    Gyehoek.Wasm
    Gyehoek.Driver
  build-depends:
    , base                  ^>=4.21.2.0
    , binary
    , containers
    , cradle
    , effectful
    , effectful-core
    , effectful-plugin
    , filepath
    , generic-lens
    , hashable
    , invertible-grammar
    , lens
    , megaparsec
@@ -59,15 +76,28 @@ executable gyehoek
    , optparse-applicative
    , prettyprinter
    , process
    , qbe
    , recursion-schemes
    , sexp-grammar
    , template-haskell
    , text
    , text-short
    , unordered-containers
    , vector
-    , text-short
+    , string-interpolate
-    , cradle
+    , 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
@@ -0,0 +1,20 @@
 <html>
  <head>
    <script>
      const imports = {
          guppy: {
              print: (arg) => console.log (arg)
          }
      }
      fetch("u.wasm")
    .then((response) => response.arrayBuffer())
    .then((bytes) => WebAssembly.instantiate(bytes, imports))
    .then((results) => {
        results.instance.exports.main ();
    });
    </script>
  </head>
  <body>
  </body>
 </html>
@@ -1,21 +0,0 @@
 #include <stdio.h>
 #include <libguile/scm.h>
 #if (-1 >> 2 == -1) && (-4 >> 2 == -1) && (-5 >> 2 == -2) && (-8 >> 2 == -2)
 # define SCM_SRS(x, y)  ((x) >> (y))
 #else
 # define SCM_SRS(x, y)                                   \
  ((x) < 0                                               \
   ? -1 - (scm_t_signed_bits) (~(scm_t_bits)(x) >> (y))  \
   : ((x) >> (y)))
 #endif
 int main () {
  unsigned long mask = 0xfffffffffffffffe;
  unsigned long x = (4 << 2) + 2;
  unsigned long y = (2 << 2) + 2;
  unsigned long z = ((x + y) >> 2) + 2;
  printf ("BLAH: %d\n", BLAH);
  printf ("%ld\n", sizeof(long));
  printf ("%lx\n", (long) z >> 2);
 }
@@ -1,48 +0,0 @@
 #include <stdio.h>
 #include <string.h>
 #include "../runtime/gyehoek.h"
 #include "../runtime/weak-set.h"
 static int
 symbol_lookup_predicate_fn (SCM sym1, void *closure) {
  const SCM sym2 = *((SCM*)closure);
  const int symp1 = SCM_SYMBOLP (sym1);
  const int symp2 = SCM_SYMBOLP (sym2);
  // both symbols?
  if (SCM_SYMBOLP (sym1) && SCM_SYMBOLP (sym2)) {
    const SCM str1 = SCM_CELL_OBJECT (sym1, 2);
    const SCM str2 = SCM_CELL_OBJECT (sym2, 2);
    const size_t len1 = scm_c_string_length (str1);
    const size_t len2 = scm_c_string_length (str2);
    // same length?
    if (len1 == len2) {
      // same name?
      const char * const s1 = scm_c_string_chars (str1);
      const char * const s2 = scm_c_string_chars (str2);
      return strncmp (s1, s2, len1);
    }
  }
  return 0;
 }
 SCM test (SCM set, const char *sym_name, SCM value) {
  SCM str = scm_from_cstring (sym_name);
  SCM sym = scm_make_symbol (str, scm_c_hash (str));
  SCM r = scm_c_weak_set_insert (set, scm_c_hash (str), value,
                                 symbol_lookup_predicate_fn,
                                 &sym);
  printf ("%ld\n", weak_set_count (set));
  return r;
 }
 int main () {
  /* const char s[] = "wormy"; */
  /* const SCM str = scm_from_utf8_string (s, sizeof(s)); */
  /* const unsigned long hash = scm_c_hash (str); */
  /* printf ("%ld\n", hash); */
  SCM set = scm_c_make_weak_set (31);
  test (set, "my-symbol", SCM_PACK (SCM_MAKE_SMALL_INT (123)));
  test (set, "my-symbol", SCM_PACK (SCM_MAKE_SMALL_INT (123)));
  test (set, "my-symbol2", SCM_PACK (SCM_MAKE_SMALL_INT (456)));
 }
@@ -1,4 +0,0 @@
 ;;; -*- mode:scheme -*-
 (let ((x0 (prim:write "abc"))) x0)
@@ -1,23 +0,0 @@
 .data
 .balign 8
 .1:
 	.ascii "abc"
 /* end data */
 .text
 .globl main
 main:
 	pushq %rbp
 	movq %rsp, %rbp
 	movl $3, %esi
 	leaq .1(%rip), %rdi
 	callq scm_from_utf8_string
 	movq %rax, %rdi
 	callq scm_write
 	leave
 	ret
 .type main, @function
 .size main, .-main
 /* end function main */
 .section .note.GNU-stack,"",@progbits
@@ -1 +0,0 @@
 (prim:write "abc")
@@ -1,10 +0,0 @@
 data $.1 =
 {b "abc"}
 export
 function w $main () {
@start
    %.2 =l call $scm_from_utf8_string (l $.1, l 3)
    %x0 =l call $scm_write (l %.2)
    ret %x0
 }
@@ -1,4 +0,0 @@
 ;;; -*- mode:scheme -*-
 (let ((x0 (prim:cons 4 2)) (x1 (prim:write x0))) x1)
@@ -1,18 +0,0 @@
 .text
 .globl main
 main:
 	pushq %rbp
 	movq %rsp, %rbp
 	movl $16, %edi
 	callq GC_malloc
 	movq %rax, %rdi
 	movq $18, (%rdi)
 	movq $10, 8(%rdi)
 	callq scm_write
 	leave
 	ret
 .type main, @function
 .size main, .-main
 /* end function main */
 .section .note.GNU-stack,"",@progbits
@@ -1 +0,0 @@
 (prim:write (prim:cons 4 2))
@@ -1,10 +0,0 @@
 export
 function w $main () {
@start
    %x0 =l call $GC_malloc (l 16)
    %.2 =l add %x0, 8
    storel 18, %x0
    storel 10, %.2
    %x1 =l call $scm_write (l %x0)
    ret %x1
 }
@@ -1,31 +0,0 @@
 .data
 .balign 8
 fstr:
 	.ascii "%s"
 	.byte 0
 /* end data */
 .data
 .balign 8
 str:
 	.ascii "안녕하세요"
 	.byte 0
 /* end data */
 .text
 .globl main
 main:
 	pushq %rbp
 	movq %rsp, %rbp
 	leaq str(%rip), %rsi
 	leaq fstr(%rip), %rdi
 	movl $0, %eax
 	callq printf
 	movl $0, %eax
 	leave
 	ret
 .type main, @function
 .size main, .-main
 /* end function main */
 .section .note.GNU-stack,"",@progbits
@@ -1,8 +0,0 @@
 data $fstr = { b "%s", b 0 }
 data $str = { b "안녕하세요", b 0 }
 export function w $main () {
@start
 	call $printf (l $fstr, ..., l $str)
 	ret 0
 }
@@ -0,0 +1,2 @@
 #!/usr/bin/env sh
 cabal repl --repl-options "-interactive-print=Text.Pretty.Simple.pPrint" --build-depends pretty-simple
@@ -1 +0,0 @@
 use flake
@@ -1 +0,0 @@
 target
@@ -1,56 +0,0 @@
 # This file is automatically @generated by Cargo.
 # It is not intended for manual editing.
 version = 4
 [[package]]
 name = "bdwgc-alloc"
 version = "0.6.13"
 source = "git+https://git.deertopia.net/msyds/bdwgc-rust.git#ccc273a168f3ddfee0a2ae170f561f19da8c274a"
 dependencies = [
 "cmake",
 "libc",
 ]
 [[package]]
 name = "cc"
 version = "1.2.62"
 source = "registry+https://github.com/rust-lang/crates.io-index"
 checksum = "a1dce859f0832a7d088c4f1119888ab94ef4b5d6795d1ce05afb7fe159d79f98"
 dependencies = [
 "find-msvc-tools",
 "shlex",
 ]
 [[package]]
 name = "cmake"
 version = "0.1.58"
 source = "registry+https://github.com/rust-lang/crates.io-index"
 checksum = "c0f78a02292a74a88ac736019ab962ece0bc380e3f977bf72e376c5d78ff0678"
 dependencies = [
 "cc",
 ]
 [[package]]
 name = "find-msvc-tools"
 version = "0.1.9"
 source = "registry+https://github.com/rust-lang/crates.io-index"
 checksum = "5baebc0774151f905a1a2cc41989300b1e6fbb29aff0ceffa1064fdd3088d582"
 [[package]]
 name = "gyehoek"
 version = "0.1.0"
 dependencies = [
 "bdwgc-alloc",
 ]
 [[package]]
 name = "libc"
 version = "0.2.186"
 source = "registry+https://github.com/rust-lang/crates.io-index"
 checksum = "68ab91017fe16c622486840e4c83c9a37afeff978bd239b5293d61ece587de66"
 [[package]]
 name = "shlex"
 version = "1.3.0"
 source = "registry+https://github.com/rust-lang/crates.io-index"
 checksum = "0fda2ff0d084019ba4d7c6f371c95d8fd75ce3524c3cb8fb653a3023f6323e64"
@@ -1,17 +0,0 @@
 [package]
 name = "gyehoek"
 version = "0.1.0"
 edition = "2024"
 [lib]
 name = "gyehoek"
 # crate-type = ["cdylib"]
 crate-type = ["staticlib"]
 [dependencies]
 bdwgc-alloc = { version = "0.6.13"
              , default-features = false
              , features = ["cmake"] }
 [patch.crates-io]
 bdwgc-alloc = { git = 'https://git.deertopia.net/msyds/bdwgc-rust.git' }
@@ -1,24 +0,0 @@
 { lib
 , rustPlatform
 , bdwgc
 , cmake
 , pkg-config
 }:
 rustPlatform.buildRustPackage (finalAttrs: {
  pname = "gyehoek-runtime";
  version = "0.0.1";
  src = ./.;
  cargoLock = {
    lockFile = ./Cargo.lock;
    outputHashes."bdwgc-alloc-0.6.13" =
      "sha256-8/EZ9FThVVsdkwB+OIlNHQJxIr6DPf701Mlfq5U1j4E=";
  };
  nativeBuildInputs = [
    pkg-config
    cmake
  ];
  buildInputs = [
    bdwgc
  ];
 })
@@ -1,109 +0,0 @@
 use std::{io::{stdout, Write}};
 const scm_tc3_cons: u64 = 0;
 const scm_tc2_int: u64 = 2;
 type scm_bits = u64;
 #[repr(C)]
 #[derive(Clone, Copy)]
 struct SCM {
    n : scm_bits
 }
 fn scm_pack (bits : scm_bits) -> SCM {
    SCM {n: bits}
 }
 fn scm_unpack (x : SCM) -> scm_bits {
    x.n
 }
 fn scm_unpack_pointer (x : SCM) -> *mut scm_bits {
    x.n as *mut scm_bits
 }
 fn scm_pack_pointer (x : *const scm_bits) -> SCM {
    SCM {n: x as scm_bits}
 }
 fn scm_cell_object (x: SCM, n: usize) -> SCM {
    let p = scm_unpack_pointer (x) as *mut SCM;
    unsafe {
        *(p.wrapping_add (n))
    }
 }
 fn scm_cell_word (x: SCM, n: usize) -> scm_bits {
    scm_unpack (scm_cell_object (x, n))
 }
 fn is_immediate (x: SCM) -> bool {
    6 & scm_unpack (x) != 0
 }
 fn scm_cell_type (x: SCM) -> scm_bits {
    scm_cell_word (x, 0)
 }
 fn is_cons (x: SCM) -> bool {
    ! is_immediate (x) && (1 & scm_cell_type (x)) == 0
 }
 fn is_small_int (x: SCM) -> bool {
    3 & scm_unpack (x) == scm_tc2_int
 }
 fn get_small_int (x: SCM) -> scm_bits {
    scm_unpack (x) >> 2
 }
 fn scm_car (x: SCM) -> SCM {
    scm_cell_object (x, 0)
 }
 fn scm_cdr (x: SCM) -> SCM {
    scm_cell_object (x, 1)
 }
 #[unsafe(no_mangle)]
 pub extern "C" fn scm_write (x: SCM) -> SCM {
    if is_small_int (x) {
        print! ("{:?}", get_small_int (x));
    } else if is_cons (x) {
        print! ("(");
        scm_write (scm_car (x));
        print! (" . ");
        scm_write (scm_cdr (x));
        print! (")");
    } else {
        let ty = if is_immediate (x) { "immediate" } else { "heap object" };
        print! ("#<{ty} {:#016x}>", scm_unpack (x));
    }
    stdout ().flush ();
    return scm_pack (0);
 }
 #[unsafe(no_mangle)]
 pub extern "C" fn scm_from_utf8_string (s: scm_bits, len: scm_bits) -> scm_bits {
    println! ("scm_from_utf8_string");
    return 0;
 }
 pub fn add (left: u64, right: u64) -> u64 {
    left + right
 }
 #[cfg(test)]
 mod tests {
    use super::*;
    #[test]
    fn it_works () {
        let result = add (2, 2);
        assert_eq! (result, 4);
    }
 }
@@ -0,0 +1,14 @@
 { 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]}
  ''
@@ -0,0 +1,63 @@
 {-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Convert
  ( convert
  , convertProgram
  ) where
 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
 -- 뻘짓이어라
 telescope
  :: Traversable t
  => (a -> (b -> r) -> r)
  -> t a -> (t b -> r) -> r
 telescope f = Cont.runCont . traverse (Cont.cont . f)
 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.ExpPrim p) k =
  telescope (convert @es) p \p' -> do
    r <- gensym' "r"
    ExpPrim p' [r] <$> k (ValVar r)
 convert (Scm.ExpLambda xs e) k = do
  f <- gensym' "λ-body"
  ktail <- gensym' "λ-tail"
  m <- convert e $ \e' ->
    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
    r <- gensym' "r"
    x <- gensym' "x"
    m <- k (ValVar x)
    pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r])
 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
@@ -0,0 +1,250 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE MultilineStrings #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ApplicativeDo #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.CPS.Lower
  (lower, lowerProgram) where
 import Gyehoek.CPS.Syntax
 import Data.Generics.Labels
 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 Effectful.Writer.Static.Local
 import Data.Text (Text)
 import Data.Vector.Strict (Vector)
 import Control.Lens
 import Data.Foldable
 import Data.HashMap.Strict (HashMap)
 import Numeric.Natural
 import GHC.Generics (Generic)
 import Gyehoek.Scheme.Syntax (Lit(..))
 import Text.Printf
 import qualified Data.Text as T
 import qualified Data.Vector.Strict as V
 import Data.IntMap.Strict (IntMap)
 import Data.String.Interpolate
 import Gyehoek.Wasm qualified as Wasm
 import Gyehoek.Wasm hiding (Expr)
 import Language.Sexp.Located (pattern ParenList)
 import Debug.Pretty.Simple
 import Control.Monad.Fix
 data Env = MkEnv
  { runtime :: Runtime
  , vars :: Vector Name
  , kvars :: Vector Name
  }
  deriving (Show, Generic)
 type instance Index Env = Natural
 type instance IxValue Env = Name
 instance Ixed Env where
  ix i = #vars . ix (fromIntegral i)
 data Runtime = MkRuntime
  { argArrayType :: Idx
  , argArray :: Idx
  , contType :: Idx
  , contStackType :: Idx
  , contStackTop :: Idx
  , contStack :: Idx
  , result :: Idx
  , halt :: Idx
  }
  deriving (Show, Generic)
 -- | @makeSmallFixnum@ emits an expression injecting the i32 on top
 -- of the stack into the SCM unitype.
 makeSmallFixnum :: Wasm.Expr
 makeSmallFixnum = mconcat
  [ ins "i32.const" [sxp @Int 1]
  , ins "i32.shl" []
  , ins "ref.i31" []
  ]
 -- | Given an expression @e@ leaving a @ref eq@ atop the stack,
 -- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
 -- result of @e@.
 pushArg :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr
 pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat
  [ ins "global.get" [sxp argArray]
  , ins "i32.const" [sxp n]
  , e
  , ins "array.set" [sxp argArrayType]
  ]
 -- | Pop the nth arg from the arg-passing array onto the stack.
 popArg :: Runtime -> Int -> Wasm.Expr
 popArg (MkRuntime {argArrayType,argArray}) n = mconcat
  [ ins "global.get" [sxp argArray]
  , ins "i32.const" [sxp n]
  , ins "array.get" [sxp argArrayType]
  , ins "ref.as_non_null" []
  ]
 lowerVal :: Env -> Val -> Wasm.Expr
 lowerVal g (ValLit l) =
  case l of
    LitInt n -> 
      ins "i32.const" [sxp n]
      <> makeSmallFixnum
    LitBool b ->
      ins "i32.const" [sxp @Int $ if b then 1 else 0]
      <> ins "ref.i31" []
    _ -> _
 lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
  where
    l = V.elemIndex x g.vars ^?! _Just
 lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 lower' g (Halt [v]) = pure . mconcat $
  [ pushArg g.runtime 0 (lowerVal g v)
  , ins "return_call" [sxp @Int 1]
  ]
 lower' g (ExpPrim p rs e) =
  case p of
    PrimAdd x y -> lowerBinOp "i32.add" g x y r e
    PrimMul x y -> lowerBinOp "i32.mul" g x y r e
  where
    r = head rs
 lower' g (ExpIf c t f) = do
  t' <- lower' g t
  f' <- lower' g f
  pure $ lowerVal g c
    <> Wasm.if' (Wasm.result [i32]) t' f'
 lower' g (ExpContinue k [x]) = pure . mconcat $
  [ pushArg rt 0 (lowerVal g x)
  , ins "i32.const" [sxp @Int 1] -- nargs
  -- get the return continuation.
  , ins "global.get" [sxp rt.contStack]
  , ins "global.get" [sxp rt.contStackTop]
  , ins "array.get" [sxp rt.contStackType]
  , ins "ref.as_non_null" []
  -- decrement contStackTop, completing the "pop."
  , ins "global.get" [sxp rt.contStackTop]
  , ins "i32.const" [sxp @Int (1 + l)]
  , ins "i32.sub" []
  , ins "global.set" [sxp rt.contStackTop]
  , ins "return_call_ref" [sxp rt.contType]
  ]
  where
    rt = g.runtime
    l = V.elemIndex k g.kvars ^?! _Just
 lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
  idx <- defun [i32] [] (replicate 5 scm) \_ -> do
    let g' = g & #vars <>~ V.fromList xs
               & #kvars <>~ [ktail]
    m' <- lower' g' m
    pure . mconcat $
      [ xs & ifoldMap \n _ ->
          popArg g.runtime n <> ins "local.set" [sxp (1+n)]
      , m'
      ]
  declareFuncref idx
  let g' = g & #vars <>~ [r]
  let n = length g.vars
  e' <- lower' g' e
  pure . mconcat $
    [ ins "ref.func" [sxp idx]
    , ins "local.set" [sxp (n+1)]
    , e'
    ]
 lower' g e = error . show $ e
 lowerBinOp
  :: (GenMod :> es)
  => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
 lowerBinOp op g x y r e = do
  e' <- lower' g' e
  pure . mconcat $
    [ lowerVal g x
    , ins "ref.cast" [sxp $ ref i31]
    , ins "i31.get_s" []
    , lowerVal g y
    , ins "ref.cast" [sxp $ ref i31]
    , ins "i31.get_s" []
    , ins op []
    , ins "ref.i31" []
    , ins "local.set" [sxp (1+n)]
    , e'
    ]
  where
    g' = g & #vars <>~ [r]
    n = length (g ^. #vars)
 scm = ref eq
 emitRuntime :: GenMod :> es => Eff es Runtime
 emitRuntime = mfix \runtime -> do
  heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
    [ Wasm.mut i32 ]
  -- cont stack
  contType <- Wasm.deftype $ Wasm.func [i32] []
  contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
  contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
  contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
    ins "i32.const" [sxp @Int 128]
    <> ins "array.new_default" [sxp contStackType]
  -- arg array
  argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
  argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
    ins "i32.const" [sxp @Int 32]
    <> ins "array.new_default" [sxp argArrayType]
  -- consIdx <- Wasm.defun _ _ _ _
  result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
  halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
    pure . mconcat $
      [ popArg runtime 0
      , ins "global.set" [sxp result]
      ]
  pure $ MkRuntime
    {argArray,argArrayType
    ,contStack,contStackTop,contStackType,contType
    ,result,halt}
  -- pure $ error "todo"
 lower :: Exp -> Eff es Text
 lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
  runtime <- emitRuntime
  let g = MkEnv runtime mempty mempty
  scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
    lower' g e
  main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
    pure . mconcat $
      -- push return cont
      [--  ins "ref.func" [sxp halt]
      -- make call
      ins "i32.const" [sxp @Int 0]
      , ins "call" [sxp scm_entry]
      , ins "global.get" [sxp runtime.result]
      , ins "ref.as_non_null" []
      ]
  Wasm.export "main" "func" main
 lowerProgram :: Program -> Eff es Text
 lowerProgram (MkProgram e) = lower e
@@ -0,0 +1,139 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Gyehoek.CPS.Syntax
  ( Val(..)
  , Kappa(..)
  , Lambda(..)
  , Exp(..)
  , Name(..)
  , Prim(..)
  , Program(..)
  , Lit(..)
  , pattern Void
  , pattern Halt
  , pattern Halt1
  , _MkKappa
  , _ExpPrim
  , _ExpFix
  , _ExpApply
  )
  where
 import Language.SexpGrammar qualified as S
 import Gyehoek.Sexp qualified
 import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
 import Data.Text (Text)
 import Data.List (List)
 import GHC.Generics (Generic)
 import Language.SexpGrammar.Generic
 import Control.Category
 import Control.Lens
 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
 data Val
  = ValLabel Name
  | ValVar Name
  | ValLit Lit
  deriving (Show, Generic)
 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
  | 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
 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
 -- SexpIso instances
 instance S.SexpIso Val where
  sexpIso = match
    $ With (. label)
    $ With (. var)
    $ With (. S.sexpIso)
    $ End
    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)
    $ End
    where
      kappa = S.list $
        S.el Gyehoek.Sexp.kappaKeyword
        >>> S.el (S.list $ S.rest S.sexpIso)
        >>> S.el S.sexpIso
 instance S.SexpIso Exp where
  sexpIso = match
    $ With (. prim)
    $ With (. fix)
    $ With (. let_)
    $ With (. continue)
    $ With (. if_)
    $ With (. app)
    $ End
    where
      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
@@ -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)
@@ -6,7 +6,6 @@ import Numeric.Natural
 import Effectful.State.Dynamic
 import Effectful.Dispatch.Dynamic
 import Effectful
 import Language.QBE as QBE
 import Data.String (IsString(fromString))
 import Data.Text (Text)
 import qualified Data.Text.Short as ST
@@ -33,10 +32,14 @@ runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \cases
  _ GenSym -> state \n -> (gen n, succ n)
  _ (GenSym' s) -> state \n -> (gen' s n, succ n)
 instance Gen (QBE.Ident s) where
  gen = Ident . fromString . ('.':) . show
  gen' s = Ident . (ST.fromText s <>) . fromString . show
 instance Gen Text where
  gen = fromString . ('x':) . show
  gen' s = (s <>) . fromString . show
 instance Gen Natural where
  gen = id
  gen' = const id
 instance Gen Int where
  gen = fromIntegral
  gen' _ = fromIntegral
@@ -17,8 +17,10 @@ import GHC.Generics (Generic)
 data Options = MkOptions
  { -- dumpANF :: Maybe FilePath
  -- , dumpQBE :: Maybe FilePath
-  output :: Maybe FilePath
+  dumpCPS :: Bool
-  , sourceFiles :: HashSet FilePath
+  , dumpParsed :: Bool
  , output :: FilePath
  , sourceFile :: FilePath
  }
  deriving (Show, Generic)
@@ -38,14 +40,19 @@ data Options = MkOptions
 --     <> metavar "FILE"
 --     )
-parseOutput =
+parseOutput = strOption
  optional $ strOption
    ( long "output"
    <> short 'o'
    <> metavar "FILE"
    <> value "-"
    )
 parseDumpCPS = switch (long "dump-cps")
 parseDumpParsed = switch (long "dump-parsed")
 parser :: Parser Options
 parser = MkOptions
-  <$> parseOutput
+  <$> parseDumpCPS
-  <*> (HS.fromList <$> some (argument str (metavar "FILES")))
+  <*> parseDumpParsed
  <*> parseOutput
  <*> argument str (metavar "FILE")
@@ -0,0 +1,266 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OrPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
 module Gyehoek.Scheme.Syntax
  ( Name(..)
  , Prim(..)
  , Lit(..)
  , Def(..)
  , Exp(..)
  , Sexp(..)
  , Program(..)
  , CommandOrDef(..)
  , primSexpIso
  , pattern Void
  , free
  , qexp
  , qprog
  , subst
  , freeVariables
  )
  where
 import Data.Text (Text)
 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)
 import Control.Category
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Gyehoek.Sexp qualified
 import Gyehoek.GenSym (Gen)
 import Control.Lens
 import Data.String (IsString)
 import Data.Hashable (Hashable)
 import Control.Lens.Unsound (prismSum)
 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)
 newtype Name = MkName { getName :: Text }
  deriving newtype (Show, Eq, IsString, Gen, Hashable)
  deriving stock (Generic, Data)
 data Prim e
  = PrimAdd e e
  | PrimSub e e
  | PrimMul e e
  | PrimDiv e e
  | PrimCons e e
  | PrimCar e
  | PrimCdr e
  | PrimImmediateP e
  | PrimConsP e
  | PrimIntegerP e
  | PrimWrite e
  | PrimZeroP e
  | PrimNewline
  deriving (Show, Generic, Functor, Foldable, Traversable, Data)
 instance Each (Prim e) (Prim e') e e'
 data Lit
  = LitInt Int
  | LitNil
  | LitBool Bool
  | LitString Text
  | LitQuote Sexp
  deriving (Show, Generic, Data)
 pattern Void :: Lit
 pattern Void = LitNil
 data Def
  = DefConstant Name Exp
  | DefProcedure Name (List Name) (List Exp)
  deriving (Show, Generic, Data)
 data Exp
  = ExpLet (NonEmpty (Name, Exp)) Exp
  | ExpPrim (Prim Exp)
  | ExpBegin (List Exp)
  | ExpIf Exp Exp Exp
  | ExpLit Lit
  | ExpLambda (List Name) Exp
  | ExpVar Name
  | ExpApply Exp (List Exp)
  deriving (Show, Generic, Data)
 data Sexp
  = SexpCons Sexp Sexp
  | SexpSymbol Text
  | SexpLit Lit
  deriving (Show, Generic, Data)
 data CommandOrDef
  = Command Exp
  | Definition Def
  | Begin (List CommandOrDef)
  deriving (Show, Generic, Data)
 data Program = MkProgram
  { commandsAndDefs :: List CommandOrDef
  }
  deriving (Show, Generic, Data)
 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
 makeBaseFunctor ''Exp
 instance SexpIso Name where
  sexpIso = symbol >>> Sexp.partialOsi f g
    where
      f = Right . MkName
      g (MkName s) = s
 primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
 primSexpIso namefn a = match
    $ With (. binop "+")
    $ With (. binop "-")
    $ With (. binop "*")
    $ With (. binop "/")
    $ With (. binop "cons")
    $ With (. unop "car")
    $ With (. unop "cdr")
    $ With (. unop "immediate?")
    $ With (. unop "cons?")
    $ With (. unop "integer?")
    $ With (. unop "write")
    $ With (. unop "zero?")
    $ With (. nullop "newline")
    $ End
    where
      idn s = el (sym (namefn s))
      nullop s = list $ idn s
      unop s = list $ idn s >>> el a
      binop s = list $ idn s >>> el a >>> el a
 instance SexpIso a => SexpIso (Prim a) where
  -- sexpIso = primSexpIso ("prim:"<>) sexpIso
  sexpIso = primSexpIso id sexpIso
 instance SexpIso Lit where
  sexpIso = match
    $ With (. sexpIso)
    $ With (. sym "nil")
    $ 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
    $ With (\cons -> cons . Gyehoek.Sexp.todo)
    $ With (\s -> s . symbol)
    $ With (\lit -> lit . sexpIso)
    $ End
 instance SexpIso Def where
  sexpIso = match
    $ With (. defconst)
    $ With (. defun)
    $ End
    where
      defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
      args = list $ el sexpIso >>> rest sexpIso
 instance SexpIso Exp where
  sexpIso = match
    $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
    $ With (. sexpIso)
    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
    $ With (. if_)
    $ With (. sexpIso)
    $ With (. lam)
    $ With (. sexpIso)
    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
    $ End
    where
      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
      lam = list
        ( 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
 -- utilities
 qexp = Gyehoek.Sexp.makeSx $ sexpIso @Exp
 qprog = Gyehoek.Sexp.makeSxs (sexpIso @CommandOrDef) MkProgram
 free :: Exp -> HashSet Name
 free = cata \case
  ExpVarF x -> HS.singleton x
  ExpLetF bs e -> error "todo lol"
  ExpLambdaF binders vs -> deleteFrom binders vs
  e -> fold e
 deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
 deleteFrom = flip $ foldr HS.delete
 insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
 insertFrom = flip $ foldr HS.insert
 subst :: (Name -> Maybe Exp) -> Exp -> Exp
 subst f = \e -> cata go e mempty where
  go (ExpVarF x) bound
    | not (x `HS.member` bound), Just e' <- f x = e'
    | otherwise                         = ExpVar x
  go (ExpLetF _ _) _ = error "todo lol"
  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
  go e bound = embed $ fmap ($ bound) e
 -- | Unlawful!
 freeVariables :: Traversal Exp Exp Name Exp
 freeVariables k = \e -> cataA go e mempty where
  go (ExpVarF x) bound
    | not (x `HS.member` bound) = k x
    | otherwise                 = pure $ ExpVar x
  go (ExpLetF _ _) _ = error "todo lol"
  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
  go e bound = embed <$> traverse ($ bound) e
@@ -0,0 +1,330 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
 {-# LANGUAGE OrPatterns #-}
 module Gyehoek.Sexp
  ( let_
  , sexp
  , nonempty
  , nonEmptyGrammar
  , encode
  , decode
  , parseSexps
  , prefixSugar
  , todo
  , isoIso
  , encodeWith
  , decodeWith
  , kappa
  , lambda
  , kappaKeyword
  , lambdaKeyword
  , encodePrettyWith
  , encodePretty
  , UglySexpIso(..)
  , AsSexpIso(..)
  , parseSexpsWithPos
  , parseSexpWithPos
  , parseSexp
  , sx
  , sxs
  , makeSx
  , makeSxs
  )
 where
 import Data.Text (Text)
 import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp qualified as S
 import Language.SexpGrammar.Generic
 import Data.InvertibleGrammar.Base qualified as IGB
 import Data.InvertibleGrammar qualified as IG
 import Data.InvertibleGrammar.Base ((:-)((:-)))
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.List.NonEmpty qualified as NE
 import Data.List (List, groupBy)
 import Data.Text.Encoding
 import Data.Either (either)
 import GHC.Generics (Generic)
 import Control.Lens
 import Data.Generics.Labels
 import System.Process
 import GHC.IO.Unsafe (unsafePerformIO)
 import qualified Data.Text.IO as TIO
 import Control.Monad (join)
 import qualified Language.Sexp.Located as SL
 import Data.Void (absurd, Void)
 import Data.Coerce (coerce)
 import qualified Data.Map
 import Language.Haskell.TH.Quote
 import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE)
 import qualified Data.Text as T
 import qualified Control.Category
 import Data.Data (Data, Typeable, cast)
 import Language.Haskell.TH.Syntax (lift, Lift)
 sexp :: SexpIso a => Iso' a Text
 sexp = iso
  (either error id . encode)
  (either error id . decode)
 encode :: SexpIso a => a -> Either String Text
 encode = encodeWith sexpIso
 decode :: SexpIso a => Text -> Either String a
 decode = decodeWith sexpIso
 encodeWith :: SexpGrammar a -> a -> Either String Text
 encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g
 encodePretty :: SexpIso a => a -> Either String Text
 encodePretty = encodePrettyWith sexpIso
 decodeWith :: SexpGrammar a -> Text -> Either String a
 decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
 encodePrettyWith :: SexpGrammar a -> a -> Either String Text
 encodePrettyWith g =
  (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g 
 parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
 parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
  where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
 parseSexp :: SexpIso a => FilePath -> Text -> Either String a
 parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
  where marshal = join . traverseOf _Right (fromSexp sexpIso)
 parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
 parseSexpsWithPos g pos =
  marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
  where marshal = join . traverseOf (_Right . each) (fromSexp g)
 parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
 parseSexpWithPos g pos =
  marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
  where marshal = join . traverseOf _Right (fromSexp g)
 nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
 nonEmptyGrammar = IGB.Iso
  (\((x:|xs) :- t) -> reverse xs :- x :- t)
  (\(xs :- x :- t) -> (x :| reverse xs) :- t)
 nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
 nonempty a =
  list (el a >>> rest a) >>>
    IG.flipped nonEmptyGrammar
 let_
  :: Text
  -> (forall t. Grammar Position (Sexp :- t) (a :- t))
  -> (forall t. Grammar Position (Sexp :- t) (b :- t))
  -> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
  -> Grammar Position (Sexp :- t1) t2
 let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
  where
    -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
    bindings = nonempty binding
    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
    binding = list (el name >>> el rhs) >>> pair
 data DotList a = MkDotList (NonEmpty a) a
  deriving (Show, Generic)
 dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
 dotlist x = list $ rest $ coproduct
  [ x >>> _
  ]
 -- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
 prefixSugar
  :: Text -> Prefix
  -> Grammar Position (Sexp :- t') a
  -> Grammar Position (Sexp :- t') a
 prefixSugar name prefix e = coproduct
  -- 'something
  [ Sexp.prefixed prefix e
  -- (quote something)
  , list $ el (sym name) >>> el e
  ]
 todo :: Grammar p (Sexp :- t) t'
 todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
  where
    f _ = Left $ unexpected "todo"
    g _ = Left $ unexpected "todo"
 kappa
  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
  -> Grammar Position (Sexp :- List a :- t1) t2
  -> Grammar Position (Sexp :- t1) t2
 kappa name e = list $
  el kappaKeyword
  >>> el (list $ rest name)
  >>> el e
 lambda
  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
  -> Grammar Position (Sexp :- List a :- t1) t2
  -> Grammar Position (Sexp :- t1) t2
 lambda name e = list $
  el lambdaKeyword
  >>> el (list $ rest name)
  >>> el e
 isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
 isoIso l = Sexp.iso (view l) (review l)
 kappaKeyword :: Grammar Position (Sexp :- t) t
 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
 instance SexpIso Sexp where
  sexpIso = Control.Category.id
 -- evil ass orphan instances
 deriving instance (Data a, Data e) => Data (SL.LocatedBy a e)
 deriving instance Data SL.Atom
 deriving instance Data SL.Prefix
 deriving instance Data SL.Position
 deriving instance (Data e) => Data (SL.SexpF e)
 -- Quasiquoter
 getPos = do
  Loc {loc_filename,loc_start} <- location
  pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
 makeSxs :: Data b => SexpGrammar a -> (List a -> b) -> QuasiQuoter
 makeSxs g f = QuasiQuoter
  { quoteExp = \str -> do
      pos <- getPos
      case parseSexpsWithPos g pos (T.pack str) of
        Left e -> fail e
        Right xs -> dataToExpQ (const Nothing) (f xs)
  , quotePat = undefined
  , quoteType = undefined
  , quoteDec = undefined
  }
 toSexp :: SexpIso a => a -> Sexp
 toSexp = either error id . Sexp.toSexp sexpIso
 pattern Unquote x =
  SL.Modified Hash (SL.BraceList [SL.Symbol x])
 pattern UnquoteSplicing x =
  SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x]))
 _UnquoteSplicing :: Prism' Sexp.Sexp Text
 _UnquoteSplicing = prism'
  UnquoteSplicing
  (\case { UnquoteSplicing x -> Just x ; _ -> Nothing })
 instance Each Sexp Sexp Sexp Sexp where
  each k (SL.ParenList xs)              = SL.ParenList <$> traverse k xs
  each k (SL.BracketList xs)            = SL.BracketList <$> traverse k xs
  each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
  each _ e@(SL.Atom _; SL.Modified _ _) = pure e
 metaSexp :: Sexp.Sexp -> Maybe ExpQ
 metaSexp (Unquote x) =
  Just [| toSexp $(varE (mkName (T.unpack x))) |]
 metaSexp (SL.ParenList xs)
  | (_:_) <- xs ^.. each . _UnquoteSplicing
  = Just [| SL.ParenList (mconcat $(listE spans)) |]
  where
    spans = xs
      & groupBy \cases
          (UnquoteSplicing _) _ -> False
          _ (UnquoteSplicing _) -> False
          _ _                   -> True
      & fmap \case
        [UnquoteSplicing x] -> varE (mkName (T.unpack x))
        x -> lift x
 metaSexp _ = Nothing
 -- 뻘짓뻘짓뻘짓뻘짓뻘짓
 class Lift1 f where
  liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp
 lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
 lift1 = liftLift lift
 instance Lift1 f => Lift (SL.Fix f) where
  lift (SL.Fix inner) = appE [|Fix|] (lift1 inner)
 instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
  liftLift l (SL.Compose fga) = [|Compose $(liftLift (liftLift l) fga)|]
 instance Lift a => Lift1 (SL.LocatedBy a) where
  liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]
 instance Lift1 List where
  liftLift l xs = listE $ l <$> xs
 instance Lift1 SL.SexpF where
  liftLift l = \case
    SL.AtomF a -> [|SL.AtomF $(lift a)|]
    SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|]
    SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|]
    SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|]
    SL.ModifiedF p e -> [|SL.Modified $(lift p) $(l e)|]
 -- deriving instance Lift a => Lift (SL.SexpF a)
 deriving instance Lift SL.Atom
 deriving instance Lift SL.Position
 deriving instance Lift SL.Prefix
 extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
 extQ f g a = maybe (f a) g (cast a)
 makeSx :: Data a => SexpGrammar a -> QuasiQuoter
 makeSx g = QuasiQuoter
  { quoteExp = \str -> do
      pos <- getPos
      case parseSexpWithPos g pos (T.pack str) of
        Left e -> fail e
        Right x -> dataToExpQ (const Nothing `extQ` metaSexp) x
  , quotePat = undefined
  , quoteType = undefined
  , quoteDec = undefined
  }
 sxs = makeSxs (sexpIso @Sexp) id
 sx = makeSx (sexpIso @Sexp)
@@ -0,0 +1,76 @@
 {- HLINT ignore "Use newtype instead of data" -}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DeepSubsumption #-}
 {-# LANGUAGE NoFieldSelectors #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE RecordPuns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ImpredicativeTypes #-}
 {-# LANGUAGE DerivingVia #-}
 module Gyehoek.Wasm
  ( Module
  )
  where
 import Language.SexpGrammar
  ( SexpIso(..), list, el, (>>>), rest, sym, symbol, (:-) )
 import Language.SexpGrammar qualified as Sexp
 import Language.SexpGrammar.Generic
 import Data.List (List)
 import GHC.Generics (Generic, Generically(..))
 import Data.Text (Text)
 import Data.String (IsString (fromString))
 import Text.Printf
 import Effectful
 import Numeric.Natural (Natural)
 import Effectful.Dispatch.Dynamic
 import Effectful.State.Dynamic
 import Control.Lens
 import Data.Generics.Labels
 import Data.Vector (Vector)
 import Data.String.Interpolate
 import qualified Data.Vector as V
 import qualified Data.Text as T
 import Effectful.Writer.Dynamic
 import Control.Applicative (Alternative((<|>)))
 import Control.Category qualified as Cat
 import Data.Vector.Lens
 import Data.Either (fromLeft, fromRight)
 import Language.Sexp.Located
 import qualified Gyehoek.Sexp
 import GHC.IsList (IsList(..))
 import Data.Coerce (coerce)
 import qualified Control.Category
 import Data.Functor (void)
 newtype Module = MkModule { inner :: Vector Sexp }
  deriving (Show, Generic)
  deriving newtype (Semigroup, Monoid)
 newtype Expr = MkExpr { inner :: Vector Sexp }
  deriving (Show, Generic)
  deriving newtype (Semigroup, Monoid)
 newtype Idx = MkIdx { inner :: Natural }
  deriving (Generic)
  deriving newtype (Show)
 -- GenMod
 -- | 'GenModState' is a 'Module' paired with the numbers of functions,
 -- types, globals, etc. defined in the module.
 data GenModState = MkGenModState
  { mod :: Module
  , funcs :: Natural
  , types :: Natural
  }
  deriving (Show, Generic)
 data GenMod :: Effect where
  DefineFunction :: Sexp -> GenMod m Idx
  DefineType :: Sexp -> GenMod m Idx
@@ -0,0 +1,18 @@
 const imports = {
    guppy: {
        print: (arg) => console.log (arg)
    }
 }
 // Assume add.wasm file exists that contains a single function adding 2 provided arguments
 const fs = require('node:fs');
 // Use the readFileSync function to read the contents of the "add.wasm" file
 const wasmBuffer = fs.readFileSync('u.wasm');
 // Use the WebAssembly.instantiate method to instantiate the WebAssembly module
 WebAssembly.instantiate(wasmBuffer, imports).then(wasmModule => {
    // Exported function lives under instance.exports object
    const { main } = wasmModule.instance.exports;
    main ()
 });
@@ -0,0 +1,69 @@
 (module
 (type $heap-object (sub (struct (field (mut i32)))))
 (type $open-procedure (func (param i32)))
 (type $closure (sub $heap-object
                     (struct (field (mut i32))
                             (field (ref $open-procedure)))))
 (type $cont-stack-type (array (mut (ref null $open-procedure))))
 (type $arg-array-type (array (mut (ref null eq))))
 (global $cont-stack-top (mut i32) (i32.const 0))
 (global $cont-stack (ref $cont-stack-type)
         (i32.const 128)
         (array.new_default $cont-stack-type))
 (global $arg-array (ref $arg-array-type)
         (i32.const 32)
         (array.new_default $arg-array-type))
 (global (mut (ref null eq)) (ref.null eq))
 (elem declare funcref (ref.func 1))
 (func
  (param i32)
  (result)
  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
  (global.get 2)
  (i32.const 0)
  (array.get 3)
  ref.as_non_null
  (global.set 3))
 (func
  (param i32)
  (result)
  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
  (global.get 2)
  (i32.const 0)
  (array.get 3)
  ref.as_non_null
  (local.set 1)
  (global.get 2)
  (i32.const 0)
  (local.get 1)
  (array.set 3)
  (i32.const 1)
  (global.get 1)
  (global.get 0)
  (array.get 2)
  ref.as_non_null
  (global.get 0)
  (i32.const 1)
  i32.sub
  (global.set 0)
  (return_call_ref 1))
 (func
  (param i32)
  (result)
  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
  (ref.func 1)
  (local.set 1)
  (global.get 2)
  (i32.const 0)
  (local.get 1)
  (array.set 3)
  (return_call 1))
 (func
  (param)
  (result (ref eq))
  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
  (i32.const 0)
  (call 1)
  (global.get 3)
  ref.as_non_null)
 (export "main" (func 3)))
@@ -0,0 +1,65 @@
 (module
 (type $heap-object (sub (struct (field (mut i32)))))
 (type $open-procedure (func (param i32)))
 (type $closure (sub $heap-object
                     (struct (field (mut i32))
                             (field (ref $open-procedure)))))
 (type $cont-stack-type (array (mut (ref null $open-procedure))))
 (type $arg-array-type (array (mut eqref)))
 (type (func (result (ref eq))))
 (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 $arg-array (ref $arg-array-type)
         (array.new_default $arg-array-type (i32.const 32)))
 (global (mut eqref) (ref.null eq))
 (elem declare funcref (ref.func 1))
 (func $halt (param i32)
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       (global.set 3
                   (ref.as_non_null
                    (array.get $arg-array-type
                               (global.get $arg-array)
                               (i32.const 0)))))
 (func $f1 (param i32)
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       ;; pop arg 0
       (local.set
        1
        (ref.as_non_null
         (array.get $arg-array-type
                    (global.get $arg-array)
                    (i32.const 0))))
       ;; push arg 0
       (array.set $arg-array-type
                  (global.get $arg-array)
                  (i32.const 0)
                  (local.get 1))
       ;; pop continuation
       (return_call_ref
        $open-procedure
        (i32.const 1)
        (ref.as_non_null (array.get $cont-stack-type
                                    (global.get $cont-stack)
                                    (global.get $cont-stack-top)))
        (global.set $cont-stack-top
                    (i32.sub
                     (global.get $cont-stack-top)
                     (i32.const 1)))))
 (func $f2 (type $open-procedure) (param i32)
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       (local.set 1
                  (struct.new $closure
                              (i32.const 0)
                              (ref.func $f1)))
       (array.set $arg-array-type
                  (global.get $arg-array)
                  (i32.const 0)
                  (local.get 1))
       (i32.const 1)
       (return_call $f1))
 (func $main (export "main") (result (ref eq))
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       (call $f2 (i32.const 0))
       (ref.as_non_null
        (global.get 3))))
@@ -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]
       ""
@@ -0,0 +1,78 @@
 (module
 (func $print (import "guppy" "print") (param i32))
 (table 2 funcref)
 (elem (i32.const 0) $halt)
 (type $cont (func (param i32)))
 (type $cont-stack-type (array (mut (ref null $cont))))
 (global $cont-stack (ref $cont-stack-type)
         (array.new_default $cont-stack-type (i32.const 128)))
 (global $cont-stack-top (mut i32) (i32.const 0))
 (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)))
 ;; (memory $memory i32 1)
 ;; (global $arg-stack-base i32 (i32.const 0))
 ;; (global $arg-stack-ptr i32 (global.get $arg-stack-base))
 ;; (global $cont-stack-base i32 (i32.const 32))
 ;; (global $cont-stack-ptr i32 (global.get $cont-stack-base))
 (func $add (param $nargs i32)
       (local $x (ref eq))
       (local $y (ref eq))
       (local $return (ref $cont))
       (local.set $x (ref.as_non_null
                      (array.get $arg-array-type
                                 (global.get $arg-array)
                                 (i32.const 0))))
       (local.set $y (ref.as_non_null
                      (array.get $arg-array-type
                                 (global.get $arg-array)
                                 (i32.const 1))))
       (array.set $arg-array-type
                  (global.get $arg-array)
                  (i32.const 0)
                  (ref.i31
                   (i32.add (i31.get_s (ref.cast (ref i31) (local.get $x)))
                            (i31.get_s (ref.cast (ref i31) (local.get $y))))))
       (return_call_ref
        $cont
        (i32.const 1)
        (block (result (ref $cont))
               (ref.as_non_null
                (array.get $cont-stack-type
                           (global.get $cont-stack)
                           (global.get $cont-stack-top)))
               (global.set $cont-stack-top
                           (i32.sub (global.get $cont-stack-top)
                                    (i32.const 1))))))
 (func $halt (param $nargs i32)
       (call $print
             (i31.get_s
              (ref.cast
               (ref i31)
               (ref.as_non_null
                (array.get $arg-array-type
                           (global.get $arg-array)
                           (i32.const 0)))))))
 (func (export "main")
       ;; push args
       (array.set $arg-array-type
                  (global.get $arg-array)
                  (i32.const 0)
                  (ref.i31 (i32.const 4)))
       (array.set $arg-array-type
                  (global.get $arg-array)
                  (i32.const 1)
                  (ref.i31 (i32.const 5)))
       ;; push return continuation
       (array.set $cont-stack-type
                  (global.get $cont-stack)
                  (i32.const 0)
                  (ref.func $halt))
       ;; make call }:)
       (return_call $add
                    ;; inform $add how many arguments we called it with
                    (i32.const 2))))
@@ -0,0 +1,26 @@
 # 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}"
  '';
 }
@@ -0,0 +1,6 @@
 # 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
Author	SHA1	Message	Date
msyds	016ac791ad	qq build / build (push) Failing after 10m37s Details	2026-07-16 03:16:59 -06:00
msyds	08b8bc50d6	idk	2026-07-15 15:18:25 -06:00
msyds	f593227a70	idk	2026-07-15 00:27:05 -06:00
msyds	60482e3567	example cont stack wat build / build (push) Failing after 1m15s Details	2026-07-14 17:36:36 -06:00
msyds	8a800fdcb2	lam build / build (push) Failing after 12m1s Details	2026-07-14 03:15:35 -06:00
msyds	269d956566	higher-order defun	2026-07-12 20:58:10 -06:00
msyds	4522e455dd	unitype	2026-07-12 12:33:46 -06:00
msyds	fdf3064665	playing with i31	2026-07-11 19:18:35 -06:00
msyds	f592a4ecbd	gitea action build / build (push) Successful in 19s Details	2026-07-11 17:48:45 -06:00
msyds	d71d78c68f	tests	2026-07-11 16:25:58 -06:00
msyds	475f0a7f68	sexp	2026-07-11 01:50:46 -06:00
msyds	b630cddb83	we r so bak	2026-07-11 00:08:35 -06:00
msyds	82927608d4	fuckeverythingggg	2026-07-10 21:14:50 -06:00
msyds	8bed7f09a5	lamlol	2026-07-07 16:38:13 -06:00
msyds	b2d9a982ac	driverslop	2026-07-06 05:01:34 -06:00
msyds	51c86a12cc	lowerslop	2026-07-05 21:49:48 -06:00
msyds	a2c93938ca	wasmslop	2026-07-05 15:14:17 -06:00
msyds	817b7530c1	cps	2026-06-30 18:42:43 -06:00
msyds	59c96f9ffb	cps	2026-06-30 15:46:14 -06:00
msyds	37b97f9eb3	fuuuuck!	2026-05-26 18:10:09 -06:00
msyds	8345763bee	reuse string lits	2026-05-26 07:06:49 -06:00
msyds	13827f880e	interned symbols	2026-05-26 02:23:08 -06:00
msyds	aca410fbc2		2026-05-25 23:13:33 -06:00
msyds	198a85afe4		2026-05-25 22:18:41 -06:00
msyds	1558c38185		2026-05-24 12:53:29 -06:00
msyds	94be79c529	strings	2026-05-23 13:30:44 -06:00
msyds	2ccf7ca27d	move code out of root	2026-05-22 15:23:31 -06:00
msyds	b1a210ef12	SCM sum type	2026-05-22 14:51:25 -06:00
msyds	4b2c026d75	idk	2026-05-20 15:48:06 -06:00
msyds	541add786d	idk	2026-05-20 13:12:48 -06:00
		`@@ -1,4 +0,0 @@`
			`;;; -- mode:scheme --`

			`(let ((x0 (prim:write "wawa"))) x0)`
		`@@ -1,4 +0,0 @@`
			`;;; -- mode:scheme --`

			`(let ((x0 (prim:cons 4 5)) (x1 (prim:write x0))) x1)`
		`@@ -1,4 +0,0 @@`
			`;;; -- mode:scheme --`

			`(let ((x0 (prim:write "안녕하세요"))) x0)`
		`@@ -1,4 +0,0 @@`
			`;;; -- mode:scheme --`

			`(let ((x0 (prim:write "abc"))) x0)`
		`@@ -1,4 +0,0 @@`
			`;;; -- mode:scheme --`

			`(let ((x0 (prim:cons 4 2)) (x1 (prim:write x0))) x1)`
		`@@ -0,0 +1,2 @@`
							`#!/usr/bin/env sh`
							`cabal repl --repl-options "-interactive-print=Text.Pretty.Simple.pPrint" --build-depends pretty-simple`