qq

src/Gyehoek/Scheme/Syntax.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OrPatterns #-}
@@ -17,6 +19,11 @@ module Gyehoek.Scheme.Syntax
   , CommandOrDef(..)
   , primSexpIso
   , pattern Void
+  , free
+  , qexp
+  , qprog
+  , subst
+  , freeVariables
   )
   where
 
@@ -37,11 +44,17 @@ 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)
+  deriving stock (Generic, Data)
 
 data Prim e
   = PrimAdd e e
@@ -57,7 +70,7 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
-  deriving (Show, Generic, Functor, Foldable, Traversable)
+  deriving (Show, Generic, Functor, Foldable, Traversable, Data)
 
 instance Each (Prim e) (Prim e') e e'
 
@@ -67,7 +80,7 @@ data Lit
   | LitBool Bool
   | LitString Text
   | LitQuote Sexp
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 pattern Void :: Lit
 pattern Void = LitNil
@@ -75,7 +88,7 @@ pattern Void = LitNil
 data Def
   = DefConstant Name Exp
   | DefProcedure Name (List Name) (List Exp)
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Exp
   = ExpLet (NonEmpty (Name, Exp)) Exp
@@ -86,24 +99,24 @@ data Exp
   | ExpLambda (List Name) Exp
   | ExpVar Name
   | ExpApply Exp (List Exp)
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Sexp
   = SexpCons Sexp Sexp
   | SexpSymbol Text
   | SexpLit Lit
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data CommandOrDef
   = Command Exp
   | Definition Def
   | Begin (List CommandOrDef)
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Program = MkProgram
   { commandsAndDefs :: List CommandOrDef
   }
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 instance Each Program Program (Either Exp Def) (Either Exp Def) where
   each = #commandsAndDefs . each . go
@@ -116,6 +129,8 @@ instance Each Program Program (Either Exp Def) (Either Exp Def) where
       go k (Definition d) = inj <$> k (Right d)
       go k (Begin xs) = Begin <$> traverse (go k) xs
 
+makeBaseFunctor ''Exp
+
 
 
 instance SexpIso Name where
@@ -211,3 +226,41 @@ instance SexpIso CommandOrDef where
     $ 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

src/Gyehoek/Sexp.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE OrPatterns #-}
 module Gyehoek.Sexp
   ( let_
   , sexp
@@ -25,11 +27,18 @@ module Gyehoek.Sexp
   , encodePretty
   , UglySexpIso(..)
   , AsSexpIso(..)
+  , parseSexpsWithPos
+  , parseSexpWithPos
+  , parseSexp
+  , sx
+  , sxs
+  , makeSx
+  , makeSxs
   )
 where
 
 import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
+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
@@ -37,7 +46,8 @@ 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.List.NonEmpty qualified as NE
+import Data.List (List, groupBy)
 import Data.Text.Encoding
 import Data.Either (either)
 import GHC.Generics (Generic)
@@ -47,10 +57,16 @@ 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 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
@@ -78,9 +94,23 @@ encodePrettyWith g =
   (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g 
 
 parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
-parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
+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)
@@ -183,3 +213,118 @@ 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)

src/Gyehoek/Wasm.hs

@@ -11,43 +11,7 @@
 {-# LANGUAGE ImpredicativeTypes #-}
 {-# LANGUAGE DerivingVia #-}
 module Gyehoek.Wasm
-  ( defun
-  , rec'
-  , start
-  , runGenMod
-  , execGenMod
-  , renderModule
-  , Module
-  , Function
-  , Type(..)
-  , Expr
-  , Instr
-  , GenMod
-  , Idx
-  , i32
-  , export
-  , ins
-  , sxp
-  , result
-  , param
-  , if'
-  , ref
-  , eq
-  , i31ref
-  , i31
-  , struct
-  , mut
-  , sub
-  , deftype
-  , namedType
-  , type'
-  , deftypeNamed
-  , defglobal
-  , array
-  , FromIdx(..)
-  , func
-  , refnull
-  , declareFuncref
+  ( Module
   )
   where
 
@@ -83,344 +47,30 @@ import qualified Control.Category
 import Data.Functor (void)
 
 
-data Module = MkModule
-  { types :: Vector RecType
-  , functions :: Vector Function
-  , funcrefs :: Vector Funcref
-  , start :: Maybe Idx
-  , exports :: Vector Export
-  , globals :: Vector Global
-  }
-  deriving (Show, Generic)
-
-instance Semigroup Module where
-  m1 <> m2 = MkModule
-    { types = m1.types <> m2.types
-    , functions = m1.functions <> m2.functions
-    , start = m2.start <|> m1.start
-    , exports = m1.exports <> m2.exports
-    , funcrefs = m1.funcrefs <> m2.funcrefs
-    , globals = m1.globals <> m2.globals
-    }
-
-instance Monoid Module where
-  mempty = MkModule mempty mempty mempty Nothing mempty mempty
-
-newtype Funcref = MkFuncref { inner :: Idx }
-  deriving (Show, Generic)
-
-data Global = MkGlobal
-  { ty :: Type
-  , body :: Expr
-  }
-  deriving (Show, Generic)
-
-newtype RecType = MkRecType { inner :: Vector Type }
-  deriving (Show, Generic)
-
-data Function = MkFunction
-  { params :: List Type
-  , result :: List Type
-  , locals :: List Type
-  , body :: Expr
-  }
-  deriving (Show, Generic)
-
-newtype Export = MkExport { inner :: Sexp }
-  deriving (Show, Generic)
-
-newtype Expr = MkExpr { inner :: Vector Instr }
+newtype Module = MkModule { inner :: Vector Sexp }
   deriving (Show, Generic)
   deriving newtype (Semigroup, Monoid)
 
-newtype Instr = MkInstr { inner :: Sexp }
+newtype Expr = MkExpr { inner :: Vector Sexp }
   deriving (Show, Generic)
+  deriving newtype (Semigroup, Monoid)
 
-newtype Type = MkType { inner :: Sexp }
-  deriving (Show, Generic)
+newtype Idx = MkIdx { inner :: Natural }
+  deriving (Generic)
+  deriving newtype (Show)
 
-data Idx
-  = IdxNumeric Natural
-  | IdxNamed Text
+
+-- 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
-  DefRecType :: List Type -> GenMod m (List Idx)
-  Defun :: List Type -> List Type -> List Type
-        -> (Idx -> m Expr) -> GenMod m Idx
-  Start :: Idx -> GenMod m ()
-  Export :: Text -> Text -> Idx -> GenMod m ()
-  DefGlobal :: Type -> Expr -> GenMod m Idx
-  DeclareFuncref :: Idx -> GenMod m ()
-
-type instance DispatchOf GenMod = Dynamic
-
-export :: (GenMod :> es) => Text -> Text -> Idx -> Eff es ()
-export name ty idx = send $ Export name ty idx
-
-start :: (GenMod :> es) => Idx -> Eff es ()
-start = send . Start
-
-rec' :: (GenMod :> es) => List Type -> Eff es (List Idx)
-rec' = send . DefRecType
-
-deftype :: (GenMod :> es) => Type -> Eff es Idx
-deftype (MkType t) = send (DefRecType [type' t]) <&> \case
-  [x] -> x
-  x -> error $ "unreachable " <> show x
-
-deftypeNamed :: (GenMod :> es) => Text -> Type -> Eff es ()
-deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t])
-
-defglobal :: (GenMod :> es) => Type -> Expr -> Eff es Idx
-defglobal t e = send $ DefGlobal t e
-
-defun
-  :: (GenMod :> es)
-  => List Type -> List Type -> List Type
-  -> (Idx -> Eff es Expr)
-  -> Eff es Idx
-defun params res locals code = send $ Defun params res locals code
-
-declareFuncref :: GenMod :> es => Idx -> Eff es ()
-declareFuncref = send . DeclareFuncref
-
--- defun
---   :: (GenMod :> es)
---   => List Type -> List Type -> List Type
---   -> (Idx -> Eff '[GenExp] a)
---   -> Eff es Idx
--- defun params result locals code =
---   send $ Defun params result locals (runPureEff . execWriterLocal . code)
-
-runGenMod :: forall es a. Eff (GenMod : es) a -> Eff es (a, Module)
-runGenMod = 
-  reinterpret (runStateLocal (mempty :: Module)) \cases
-    _ (DefRecType ts) -> state \m ->
-     ( let prev_n = sumOf (#types . each . #inner . to V.length) m
-       in IdxNumeric . fromIntegral <$> [prev_n .. prev_n + length ts - 1]
-     , m & #types <>~ V.singleton (MkRecType (V.fromList ts))
-     )
-    _ (Start idx) -> assign #start (Just idx)
-    _ (Export name ty idx) ->
-       #exports <>= V.singleton e
-      where e = MkExport $ ParenList
-              [ "export", sxp name, ParenList [ "func", sxp idx ] ]
-    env (Defun params result locals code) ->
-      localSeqUnlift env \unlift -> do
-        m <- get
-        -- the least unused function index, computed as the number
-        -- of currently allocated functions.
-        let idx = IdxNumeric . fromIntegral . length $ m.functions
-        -- the body is computed with access to the newly allocated
-        -- index `idx` for the sake of recursive occurences.
-        body <- unlift $ code idx
-        let func = MkFunction {params,result,locals,body}
-        #functions <>= V.singleton func
-        pure idx
-    _ (DefGlobal t e) -> state \m ->
-      let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals
-          m' = m & #globals <>~ V.singleton (MkGlobal t e)
-      in (prev_n, m')
-    _ (DeclareFuncref idx) -> #funcrefs <>= V.singleton (MkFuncref idx)
-
-execGenMod = fmap snd . runGenMod
-
-renderModule :: Module -> Text
-renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
-
-ref :: Type -> Type
-ref (MkType x) = MkType . ParenList $ [Symbol "ref", x]
-
-refnull :: Type -> Type
-refnull (MkType x) = MkType . ParenList $ ["ref", "null", x]
-
-sub :: List Idx -> Type -> Type
-sub supers (MkType x) = MkType . ParenList $
-  Symbol "sub" : (sxp <$> supers) ++ [x]
-
-array :: Type -> Type
-array (MkType x) = MkType . ParenList $ [Symbol "array", x]
-
-mut :: Type -> Type
-mut (MkType x) = MkType . ParenList $ [Symbol "mut", x]
-
-struct :: List Type -> Type
-struct xs = MkType . ParenList $
-  Symbol "struct" : (xs ^.. each . #inner . to field)
-  where field x = ParenList [Symbol "field", x]
-
-func :: List Type -> List Type -> Type
-func params results =
-  MkType . ParenList $
-    [ Symbol "func"
-    , wrap "param" params
-    , wrap "result" results
-    ]
-  where
-    wrap s xs = ParenList $ Symbol s : xs ^.. each . #inner
-
-i32, i31ref, eq, i31 :: Type
-i32 = MkType $ Symbol "i32"
-i31ref = MkType $ Symbol "i31ref"
-eq = MkType $ Symbol "eq"
-i31 = MkType $ Symbol "i31"
-
-class FromIdx a where
-  fromIdx :: Idx -> a
-
-instance FromIdx Type where
-  fromIdx (IdxNumeric n) = MkType . Symbol . T.pack . show $ n
-
-
-
-instance SexpIso Idx where
-  sexpIso = match
-    $ With (\numeric -> num >>> numeric)
-    $ With (\named -> name >>> named)
-    $ End
-    where
-      num = Sexp.integer >>> Sexp.partialOsi f g
-        where
-          f n | n < 0 = Left $ Sexp.unexpected "negative"
-                            <> Sexp.expected "natural"
-              | otherwise = Right $ fromIntegral n
-          g n = fromIntegral n
-      l :: Prism' Text Text
-      l = prefixed "$"
-      name = Sexp.symbol >>> Sexp.partialOsi
-        (maybe (Left $ Sexp.expected "$-prefixed sym") Right . preview l)
-        (review l)
-
-instance SexpIso RecType where
-  sexpIso = with \rectype ->
-    Sexp.coproduct
-     [ sexpIso @Type >>> Sexp.partialIso
-       (\x -> [x])
-       (\case [x] -> Right x
-              _ -> Left $ Sexp.expected "a single type")
-     , list (el (sym "rec") >>> rest sexpIso)
-     ]
-    >>> Sexp.iso V.fromList V.toList
-    >>> rectype
-    -- where
-    --   typedef
-    --     :: forall a t. Sexp.Grammar Position (Sexp :- t) (a :- t)
-    --     -> Sexp.Grammar Position (Sexp :- t) (a :- t)
-    --   typedef x = list (el (sym "type") >>> el x)
-
-type' :: Sexp -> Type
-type' e = MkType . ParenList $ [ "type", e ]
-
-namedType :: Text -> Sexp -> Type
-namedType name e = MkType . ParenList $ [ "type", Symbol name, e ]
-
-instance SexpIso Global where
-  sexpIso = with \glob ->
-    list ( el (sym "global")
-         >>> el (sexpIso @Type)
-         >>> restCode
-         )
-    >>> glob
-
-instance SexpIso Instr where
-  sexpIso = Sexp.iso coerce coerce
-
-instance SexpIso Type where
-  sexpIso = Sexp.iso coerce coerce
-
-instance SexpIso Export where
-  sexpIso = Sexp.iso coerce coerce
-
-restCode :: Sexp.Grammar Position (Sexp.List :- t) (Sexp.List :- (Expr :- t))
-restCode =
-  rest (sexpIso @Instr)
-  >>> Sexp.onTail
-           (Sexp.iso
-            (view instrsExpr)
-            (review instrsExpr))
-    where
-      instrsExpr :: Iso' (List Instr) Expr
-      instrsExpr = vector . coerced
-
-instance SexpIso Function where
-  sexpIso = with \func ->
-    list ( el (sym "func")
-       >>> el (list $ el (sym "param") >>> rest (sexpIso @Type))
-       >>> el (list $ el (sym "result") >>> rest (sexpIso @Type))
-       >>> el (list $ el (sym "local") >>> rest (sexpIso @Type))
-       >>> restCode
-         )
-     >>> func
-
-instance SexpIso Module where
-  sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->
-    ParenList $
-      [ Symbol "module" ]
-      <> (m ^.. #types . each . to sxp)
-      <> (m ^.. #globals . each . to sxp)
-      <> (m ^.. #funcrefs . each . to sxp)
-      <> (m ^.. #functions . each . to sxp)
-      <> (m ^.. #exports . each . to sxp)
-
-instance SexpIso Funcref where
-  sexpIso = with \funcref ->
-    list ( el (sym "elem")
-         >>> el (sym "declare")
-         >>> el (sym "funcref")
-         >>> el (list $ el (sym "ref.func") >>> el (sexpIso @Idx))
-         )
-    >>> funcref
-
-instance SexpIso Sexp where
-  sexpIso = Control.Category.id
-
-instance Each Expr Expr Instr Instr where
-  each = #MkExpr . each
-
-sxp :: HasCallStack => SexpIso a => a -> Sexp
-sxp e = either error id . Sexp.toSexp sexpIso $ e
-
-ins :: Text -> List Sexp -> Expr
-ins op [] = [ MkInstr $ Symbol op ]
-ins op xs = [ MkInstr . ParenList $ Symbol op : xs ]
-
-instance IsString Sexp where
-  fromString = Symbol . T.pack
-
-instance IsList Expr where
-  type Item Expr = Instr
-  fromList = MkExpr . V.fromList
-  toList e = V.toList e.inner
-
-data ResultType = MkResultType
-  { params :: List Type
-  , result :: List Type
-  }
-  deriving stock (Generic)
-  deriving (Semigroup, Monoid)
-    via Generically ResultType
-
-param :: List Type -> ResultType
-param ts = MkResultType ts mempty
-
-result :: List Type -> ResultType
-result ts = MkResultType mempty ts
-
-resultTypeSexp :: ResultType -> List Sexp
-resultTypeSexp rt =
-  f "param" (coerce <$> rt.params) <> f "result" (coerce <$> rt.result)
-  where
-    f :: Text -> List Sexp -> List Sexp
-    f _ [] = []
-    f kw s = [ ParenList $ Symbol kw : s ]
-
--- resultSexp :: ResultType -> Sexp
--- resultSexp rt = ParenList $ Symbol "param" : (coerce <$> rt.result)
-
-if' :: ResultType -> Expr -> Expr -> Expr
-if' rt t f = MkExpr . V.singleton . MkInstr . ParenList $
-  [ Symbol "if" ]
-  <> resultTypeSexp rt
-  <> [ ParenList $ Symbol "then" : (t ^.. each . to sxp) ]
-  <> [ ParenList $ Symbol "else" : (f ^.. each . to sxp) ]
+  DefineFunction :: Sexp -> GenMod m Idx
+  DefineType :: Sexp -> GenMod m Idx