"fix stuff lol"

src/Gyehoek/CPS/Lower.hs

@@ -121,7 +121,7 @@ lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 
 lower' g (Halt [v]) = pure [expr|
   ##{arg}
-  (return_call $halt)
+  (return_call $halt (i32.const 1))
 |]
   where arg = pushArg 0 (lowerVal g v)
 
@@ -183,6 +183,7 @@ lowerBinOp
   :: (GenMod :> es)
   => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
 lowerBinOp op g x y r e = do
+  let op' = SL.Symbol op
   let g' = g & #vars <>~ [r]
   let n = succ $ length (g ^. #vars)
   let x' = lowerVal g x
@@ -191,9 +192,15 @@ lowerBinOp op g x y r e = do
   pure [expr|
     ##{x'}
     (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
     ##{y'}
     (i31.get_s (ref.cast (ref i31)))
-    (local.set #{n} (ref.i31 #{op}))
+    (i32.const 1)
+    i32.shr_u
+    #{op'}
+    ##{makeSmallFixnum}
+    (local.set #{n})
     ##{e'}
   |]
 
@@ -234,6 +241,9 @@ lowerBinOp op g x y r e = do
 
 emitRuntime :: GenMod :> es => Eff es ()
 emitRuntime = mfix \runtime -> do
+  Wasm.emit [wat|
+    (import "gyehoek" "write" (func $gh-write (param (ref eq))))
+  |]
   -- cont stack
   Wasm.defineType [wat|
     (type $heap-object (sub (struct (field $hash (mut i32)))))
@@ -257,7 +267,7 @@ emitRuntime = mfix \runtime -> do
   |]
   Wasm.defineGlobal [wat|
     (global $arg-array (ref $arg-array-type)
-            (array.new_default $arg-array-type) (i32.const 32))
+            (array.new_default $arg-array-type (i32.const 32)))
   |]
   -- other  things 😼
   Wasm.defineGlobal [wat|
@@ -284,9 +294,9 @@ lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
       ##{e'})
   |]
   Wasm.defineFunction [wat|
-    (func (export "main") (result (ref eq))
+    (func (export "main")
       (call $scm-entry (i32.const 0))
-      (ref.as_non_null (global.get $result)))
+      (call $gh-write (ref.as_non_null (global.get $result))))
   |]
   
 lowerProgram :: Program -> Eff es Text
@@ -325,3 +335,17 @@ antiquote_splicing_example =
       (func $blah (param i32 i64 f64))
     |]
   in (metavars, e1, e2, e1 == e2)
+
+antiquote_both_example =
+  let
+    m1 = 123 :: Int
+    ms = [expr|i32 i64|]
+
+    e1 = [expr|
+      a (b #{m1} c) d ##{ms} e
+    |]
+
+    e2 = [expr|
+      a (b 123 c) d i32 i64 e
+    |]
+  in (e1,e2,e1==e2)

src/Gyehoek/Sexp.hs

@@ -56,7 +56,7 @@ import Data.List (List, groupBy)
 import Data.Text.Encoding
 import Data.Either (either)
 import GHC.Generics (Generic)
-import Control.Lens
+import Control.Lens hiding (para)
 import Data.Generics.Labels
 import System.Process
 import GHC.IO.Unsafe (unsafePerformIO)
@@ -71,9 +71,9 @@ import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE
 import qualified Data.Text as T
 import qualified Control.Category
 import Data.Data (Data (..), Typeable, cast)
-import Language.Haskell.TH.Syntax (lift, Lift)
+import Language.Haskell.TH.Syntax (lift, Lift, liftData)
 import GHC.IsList (fromList)
-import Data.Functor.Foldable (cata)
+import Data.Functor.Foldable (cata, para, embed)
 import Data.Functor.Classes (Show1(..))
 import Data.Vector (Vector)
 import Numeric.Natural (Natural)
@@ -81,6 +81,7 @@ import Data.Maybe (fromMaybe)
 import Control.Applicative (Alternative((<|>)))
 import Debug.Pretty.Simple
 import qualified Data.Vector as V
+import qualified Data.Vector.Strict
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -295,10 +296,12 @@ instance SexpIso Natural where
           | otherwise = Right $ fromIntegral n
       g n = fromIntegral n
 
-
 class SpliceSexp a where
   spliceSexp :: a -> List Sexp
 
+instance SexpIso a => SpliceSexp (Data.Vector.Strict.Vector a) where
+  spliceSexp = toSexps
+
 instance SexpIso a => SpliceSexp (Vector a) where
   spliceSexp = toSexps
 
@@ -329,6 +332,30 @@ unquoteSplicing xs
       & listE
 unquoteSplicing _ = Nothing
 
+unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ
+unquoteSplicingRecursive xs = [| mconcat $(spans) |]
+  where
+    spans = xs
+      & groupBy \cases
+          (UnquoteSplicing _) _ -> False
+          _ (UnquoteSplicing _) -> False
+          _ _                   -> True
+      & fmap \case
+        -- [e@(Unquote _)] ->
+        --   case unquote e of
+        --     Just x -> [| [$(x)] |]
+        --     Nothing -> error "unreachable"
+        [UnquoteSplicing x] ->
+          [| spliceSexp $(varE (mkName (T.unpack x))) |]
+        es -> listE $ unquoteRecursive <$> es
+      & listE
+
+unquoteRecursive :: Sexp.Sexp -> ExpQ
+unquoteRecursive = \case
+  Unquote x -> [| stripLocation (toSexp $(varE (mkName (T.unpack x)))) |]
+  SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|]
+  e -> liftData e
+
 unquote :: Sexp.Sexp -> Maybe ExpQ
 unquote (Unquote x) =
   Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |]
@@ -340,13 +367,10 @@ _ParenList = prism' SL.ParenList \case
   _ -> Nothing
 
 metaSexps :: List Sexp.Sexp -> Maybe ExpQ
-metaSexps = unquoteSplicing
-
-metaSexpsV :: Vector Sexp.Sexp -> Maybe ExpQ
-metaSexpsV = unquoteSplicing . V.toList
+metaSexps = Just . unquoteSplicingRecursive
 
 metaSexp :: Sexp.Sexp -> Maybe ExpQ
-metaSexp x = unquote x
+metaSexp = Just . unquoteRecursive
 
 -- 뻘짓뻘짓뻘짓뻘짓뻘짓
 class Lift1 f where

src/Gyehoek/Wasm.hs

@@ -28,7 +28,7 @@ module Gyehoek.Wasm
   , defineFunction
   , defineType
   , defineGlobal
-  , declare
+  , emit
   , renderModule
   , wat
   )
@@ -49,9 +49,9 @@ import Effectful.Dispatch.Dynamic
 import Effectful.State.Dynamic
 import Control.Lens
 import Data.Generics.Labels
-import Data.Vector (Vector)
+import Data.Vector.Strict (Vector)
 import Data.String.Interpolate
-import qualified Data.Vector as V
+import qualified Data.Vector.Strict as V
 import qualified Data.Text as T
 import Effectful.Writer.Dynamic
 import Control.Applicative (Alternative((<|>)))
@@ -124,7 +124,7 @@ data GenMod :: Effect where
   DefineFunction :: Sexp -> GenMod m Idx
   DefineType :: Sexp -> GenMod m Idx
   DefineGlobal :: Sexp -> GenMod m Idx
-  Declare :: Sexp -> GenMod m ()
+  Emit :: Sexp -> GenMod m ()
 
 type instance DispatchOf GenMod = Dynamic
 
@@ -137,8 +137,8 @@ defineType = send . DefineType
 defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
 defineGlobal = send . DefineGlobal
 
-declare :: GenMod :> es => Sexp -> Eff es ()
-declare = send . Declare
+emit :: GenMod :> es => Sexp -> Eff es ()
+emit = send . Emit
 
 appendAndIncrement
   :: State GenModState :> es
@@ -158,7 +158,7 @@ runGenMod =
     _ (DefineFunction s) -> appendAndIncrement #funcs s
     _ (DefineType s) -> appendAndIncrement #types s
     _ (DefineGlobal s) -> appendAndIncrement #globals s
-    _ (Declare s) -> #mod . #inner <>= V.singleton s
+    _ (Emit s) -> #mod . #inner <>= V.singleton s
 
 execGenMod :: Eff (GenMod : es) a -> Eff es Module
 execGenMod = fmap snd . runGenMod