continue takes var

2026-08-24 23:41:52 -06:00
parent 99d9e460fc
commit 796b967686
10 changed files with 84 additions and 541 deletions
@@ -6,182 +6,41 @@ module Gyehoek.Wasm
  (
    -- * syntax
    Module
-  , Idx
+  , Program
+  , Function
  , Expr
    -- ** quasiquoters
-  , expr
-  , S.sx
-  , S.sxs
-  -- * GenMod effect
-  , GenMod
-  , runGenMod
-  , execGenMod
-  , defineFunction
-  , defineType
-  , defineGlobal
-  , emit
-  , renderModule
+  , watM
  , wat
-  , wats
-  , defineFunctions
-  , defineTypes
-  , defineGlobals
  )
  where

 import Data.List (List)
 import GHC.Generics (Generic)
-import Data.Text (Text)
-import Effectful
-import Numeric.Natural (Natural)
-import Effectful.Dispatch.Dynamic
-import Effectful.State.Dynamic
-import Control.Lens
-import Data.Vector.Strict (Vector)
-import qualified Data.Vector.Strict as V
-import GHC.IsList (IsList(..))
 import Language.Haskell.TH.Quote (QuasiQuoter)
-import Data.Data (Data)
 import Gyehoek.Sexp qualified as S
-import Gyehoek.Sexp (Datum, sx, (>>>))
-import Data.Foldable (traverse_)
-import Data.Coerce (coerce)
+import Gyehoek.Sexp (Datum, (>>>))
+import Data.Data (Data)


-newtype Module = MkModule { inner :: Vector Datum }
-  deriving (Show, Generic)
+type Program = Module
+type Function = Datum
+type Expr = List Datum
+
+newtype Module = MkModule { inner :: List Datum }
+  deriving (Show, Generic, Data)
  deriving newtype (Semigroup, Monoid)

-newtype Expr = MkExpr { inner :: Vector Instr }
-  deriving (Show, Generic, Data, Eq)
-  deriving newtype (Semigroup, Monoid)
-
-instance IsList Expr where
-  type Item Expr = Instr
-  fromList = MkExpr . V.fromList
-  toList = V.toList . view #inner
-
-newtype Instr = MkInstr { inner :: Datum }
-  deriving (Show, Generic, Data, Eq)
-
-newtype Idx = MkIdx { inner :: Natural }
-  deriving (Generic, Data)
-  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
-  , globals :: Natural
-  }
-  deriving (Show, Generic)
-
-instance Semigroup GenModState where
-  m1 <> m2 = MkGenModState
-    { mod = m1.mod <> m2.mod
-    , funcs = m1.funcs + m2.funcs
-    , types = m1.types + m2.types
-    , globals = m1.globals + m2.globals
-    }
-
-instance Monoid GenModState where
-  mempty = MkGenModState
-    { mod = mempty
-    , funcs = 0
-    , types = 0
-    , globals = 0
-    }
-
-data GenMod :: Effect where
-  DefineFunction :: Datum -> GenMod m Idx
-  DefineType :: Datum -> GenMod m Idx
-  DefineGlobal :: Datum -> GenMod m Idx
-  Emit :: Datum -> GenMod m ()
-
-type instance DispatchOf GenMod = Dynamic
-
-defineFunction :: GenMod :> es => Datum -> Eff es Idx
-defineFunction = send . DefineFunction
-
-defineFunctions :: GenMod :> es => List Datum -> Eff es (List Idx)
-defineFunctions = traverse (send . DefineFunction)
-
-defineType :: GenMod :> es => Datum -> Eff es Idx
-defineType = send . DefineType
-
-defineTypes :: GenMod :> es => List Datum -> Eff es (List Idx)
-defineTypes = traverse (send . DefineType)
-
-defineGlobal :: GenMod :> es => Datum -> Eff es Idx
-defineGlobal = send . DefineGlobal
-
-defineGlobals :: GenMod :> es => List Datum -> Eff es (List Idx)
-defineGlobals = traverse (send . DefineGlobal)
-
-emit :: GenMod :> es => List Datum -> Eff es ()
-emit = traverse_ (send . Emit)
-
-appendAndIncrement
-  :: State GenModState :> es
-  => LensLike' ((,) Natural) GenModState Natural
-  -> Datum
-  -> Eff es Idx
-appendAndIncrement l s =
-  state \st -> st
-    & #mod . #inner <>~ V.singleton s
-    & l <<%~ succ
-    & _1 %~ MkIdx
-
-runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
-runGenMod =
-  let run = (mapped . _2 %~ view #mod) . runStateLocal (mempty @GenModState)
-  in reinterpret run \cases
-    _ (DefineFunction s) -> appendAndIncrement #funcs s
-    _ (DefineType s) -> appendAndIncrement #types s
-    _ (DefineGlobal s) -> appendAndIncrement #globals s
-    _ (Emit s) -> #mod . #inner <>= V.singleton s
-
-execGenMod :: Eff (GenMod : es) a -> Eff es Module
-execGenMod = fmap snd . runGenMod
-
-renderModule :: Module -> Text
-renderModule (MkModule ss) = S.encodeWith' S.datumIso [sx|
-  (module ##{ss})
-|]
-
-
-- DatumIso instances
-
-instance S.DatumIso Idx where
-  datumIso = S.with \idx ->
-    S.integer >>> S.partialOsi f g
-    >>> idx
-    where
-      f n | n < 0 = Left $ S.unexpected "negative"
-                        <> S.expected "natural"
-          | otherwise = Right $ fromIntegral n
-      g = fromIntegral
-
-instance S.DatumIso Instr where
-  datumIso = S.with S.id
-
-instance S.DataIso Expr where
-  dataIso = S.dataIso @(Vector Instr) >>> S.iso coerce coerce
+instance S.DatumIso Module where
+  datumIso = S.with \g ->
+    S.list (S.el (S.sym "module") >>> S.rest S.datumIso)
+    >>> g


 -- quasiquoters

-expr :: QuasiQuoter
-expr = S.makeSxs
-  [|| MkExpr . V.fromList . fmap (S.fromDatumUnsafe $ S.datumIso @Instr) ||]
-
 wat :: QuasiQuoter
-wat = S.makeSx [|| id ||]
+wat = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @(List Datum)) ||]

-wats :: QuasiQuoter
-wats = S.makeSxs [|| id ||]
+watM :: QuasiQuoter
+watM = S.makeSx [|| S.fromDatumUnsafe (S.datumIso @Module) ||]