fuckeverythingggg

app/Gyehoek/CPS/Convert.hs

@@ -28,7 +28,7 @@ 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] . pure <$> k (ValVar r)
+    ExpPrim p' [r] <$> k (ValVar r)
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "f"

app/Gyehoek/CPS/Lower.hs

@@ -30,11 +30,6 @@ import qualified Data.Vector.Strict as V
 import Data.IntMap.Strict (IntMap)
 
 
-type Emit = Writer (Vector Text)
-
-runEmit :: Eff (Emit : es) a -> Eff es (a, Text)
-runEmit = (mapped . _2 %~ fold) . runWriter
-
 data Env = MkEnv { vars :: Vector Name }
   deriving (Show, Generic)
 
@@ -49,34 +44,11 @@ instance Ixed Env where
 
 
 
--- countLocals :: Exp -> Int
-
--- countLocals (ExpPrim p rs es) = length rs + sumOf (each . to countLocals) es
-
--- countLocals (ExpFix bs e) =
---   sumOf (each . _2 . _MkKappa . ((_1 . each . to (const 1))
---                                  <> (_2 . to countLocals))) bs
---   + countLocals e
-
--- countLocals (ExpApply _ _) = 0
-
 tshow :: Show a => a -> Text
 tshow = T.pack . show
 
 
 
-data Module = MkModule
-  { funcs :: IntMap Func
-  }
-  deriving (Show, Generic)
-
-data Func = MkFunc
-  { code :: Text
-  }
-  deriving (Show, Generic)
-
-
-
 lowerVal :: Env -> Val -> Vector Text
 
 lowerVal g (ValLit l) =
@@ -92,13 +64,12 @@ lower' :: Env -> Exp -> Vector Text
 
 lower' g (Halt [e]) = lowerVal g e
 
-lower' g (ExpPrim p rs es) =
+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
-    e = head es
 
 lowerBinOp op g x y r e =
   lowerVal g x

app/Gyehoek/CPS/Syntax.hs

@@ -41,9 +41,10 @@ data Kappa = MkKappa (List Name) Exp
   deriving (Show, Generic)
 
 data Exp
-  = ExpPrim (Prim Val) (List Name) (List Exp)
+  = ExpPrim (Prim Val) (List Name) Exp
   | ExpFix (NonEmpty (Name, Kappa)) Exp
   | ExpApply Val (List Val)
+  | ExpIf Val Exp Exp
   deriving (Show, Generic)
 
 pattern Halt :: List Val -> Exp
@@ -83,12 +84,14 @@ instance S.SexpIso Exp where
     $ With (. prim)
     $ With (. let_)
     $ With (. app)
+    $ With (. if_)
     $ End
     where
       let_ = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso
+      if_ = S.list $ 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.rest S.sexpIso
+        >>> S.el S.sexpIso

app/Gyehoek/Wasm.hs

@@ -0,0 +1,28 @@
+{- HLINT ignore "Use newtype instead of data" -}
+module Gyehoek.Wasm
+  ()
+  where
+
+import Data.List (List)
+import GHC.Generics (Generic)
+
+
+data Module = MkModule
+  { typeSection :: List Type
+  }
+  deriving (Show, Generic)
+
+data Type
+  deriving (Show, Generic)
+
+data Function = MkFunction
+  { params :: List Type
+  , result :: List Type
+  , locals :: List Type
+  , body :: Expr
+  }
+  deriving (Show, Generic)
+
+type Expr = List Instr
+
+type Instr = ByteString

app/Gyehoek/Wasm/Build.hs

@@ -1,6 +0,0 @@
-module Gyehoek.Wasm.Build
-  () where
-
-import Gyehoek.Wasm.Syntax
-import Control.Lens
-

app/Gyehoek/Wasm/Syntax.hs

@@ -1,307 +0,0 @@
-{-# LANGUAGE OverloadedRecordDot #-}
-module Gyehoek.Wasm.Syntax
-  ( Module(..)
-  , Type
-  , Import
-  , Tag
-  , Global
-  , Mem
-  , Table
-  , Func
-  , Data
-  , Elem
-  , Export
-  , Idx
-  , TypeIdx
-  , FuncIdx
-  , GlobalIdx
-  , TableIdx
-  , MemIdx
-  , TagIdx
-  , ElemIdx
-  , DataIdx
-  , LabelIdx
-  , LocalIdx
-  , FieldIdx
-  ) where
-
-import Data.Vector (Vector)
-import Data.Word (Word32)
-import Data.Binary hiding (putList)
-import Data.Bits
-import Data.Int (Int8, Int32)
-import Data.Binary hiding (putList)
-import Data.List (List)
-import Data.Generics.Labels
-import Control.Lens
-import Data.Text (Text)
-import Control.Applicative (Alternative(..))
-import Data.Foldable (traverse_)
-import Control.Monad
-import Data.Binary.Put (runPut)
-import GHC.Generics (Generic)
-import Data.Coerce (coerce)
-
-
-type Type = RecType
-data Import
-data Tag
-data Global
-data Mem
-data Table
-data Func
-data Data
-data Elem
-data Export
-data DataCount
-data Code = MkCode { locals :: Vector Local, expr :: Expr }
-
-newtype Idx = MkIdx Word32
-  deriving (Show, Generic)
-
-newtype TypeIdx = MkType Idx
-  deriving (Show, Generic)
-  deriving newtype (Binary)
-newtype FuncIdx = MkFunc Idx
-  deriving (Show, Generic)
-  deriving newtype (Binary)
-newtype GlobalIdx = MkGlobal Idx
-  deriving (Show, Generic)
-newtype TableIdx = MkTable Idx
-  deriving (Show, Generic)
-newtype MemIdx = MkMem Idx
-  deriving (Show, Generic)
-newtype TagIdx = MkTag Idx
-  deriving (Show, Generic)
-newtype ElemIdx = MkElem Idx
-  deriving (Show, Generic)
-newtype DataIdx = MkData Idx
-  deriving (Show, Generic)
-newtype LabelIdx = MkLabel Idx
-  deriving (Show, Generic)
-newtype LocalIdx = MkLocal Idx
-  deriving (Show, Generic)
-newtype FieldIdx = MkField Idx
-  deriving (Show, Generic)
-
-data Module = MkModule
-  { types :: Vector Type
-  , imports :: Vector Import
-  , funcs :: Vector Func
-  , tables :: Vector Table
-  , mems :: Vector Mem
-  , tags :: Vector Tag
-  , globals :: Vector Global
-  , exports :: Vector Export
-  , start :: Maybe FuncIdx
-  , elems :: Vector Elem
-  , dataCounts :: Vector DataCount
-  , code :: Vector Code
-  , datas :: Vector Data
-  }
-
-instance Semigroup Module where
-  m1 <> m2 = MkModule
-    { types = m1.types <> m2.types
-    , imports = m1.imports <> m2.imports
-    , tags = m1.tags <> m2.tags
-    , globals = m1.globals <> m2.globals
-    , mems = m1.mems <> m2.mems
-    , tables = m1.tables <> m2.tables
-    , funcs = m1.funcs <> m2.funcs
-    , datas = m1.datas <> m2.datas
-    , elems = m1.elems <> m2.elems
-    , start = m1.start <|> m2.start
-    , exports = m1.exports <> m2.exports
-    }
-
-instance Monoid Module where
-  mempty = MkModule
-    { types = mempty
-    , imports = mempty
-    , funcs = mempty
-    , tables = mempty
-    , mems = mempty
-    , tags = mempty
-    , globals = mempty
-    , exports = mempty
-    , start = Nothing
-    , elems = mempty
-    , datas = mempty
-    }
-
-newtype SectionId = MkSectionId Word8
-  deriving newtype (Binary)
-
-pattern SectionCustom    = MkSectionId 0
-pattern SectionType      = MkSectionId 1
-pattern SectionImport    = MkSectionId 2
-pattern SectionFunction  = MkSectionId 3
-pattern SectionTable     = MkSectionId 4
-pattern SectionMemory    = MkSectionId 5
-pattern SectionGlobal    = MkSectionId 6
-pattern SectionExport    = MkSectionId 7
-pattern SectionStart     = MkSectionId 8
-pattern SectionElement   = MkSectionId 9
-pattern SectionCode      = MkSectionId 10
-pattern SectionData      = MkSectionId 11
-pattern SectionDataCount = MkSectionId 12
-pattern SectionTag       = MkSectionId 13
-
-newtype RecType = MkRecType { subtypes :: List SubType }
-
-data SubType
-  = MkSubType { final :: Bool, supertypes :: List TypeIdx, ct :: CompType }
-  deriving (Show, Generic)
-
-data CompType = CompTypeFunc { to :: List ValType, from :: List ValType }
-  deriving (Show, Generic)
-
-data ValType
-  = ValTypeNum NumType
-  deriving (Show, Generic)
-
-data NumType
-  = F64 | F32 | I64 | I32
-  deriving (Show, Generic)
-
-data Local
-data Expr
-
-
-
-getULEB128 :: (Integral a, Bits a) => Int -> Get a
-getULEB128 bitsBudget = do
-    if bitsBudget > 0 then return () else fail "integer representation too long"
-    val <- getWord8
-    if bitsBudget >= 7 || val .&. 0x7F < 1 `shiftL` bitsBudget then return () else fail "integer too large"
-    if not (testBit val 7)
-    then return $ fromIntegral val
-    else do
-        rest <- getULEB128 (bitsBudget - 7)
-        return $ (fromIntegral $ val .&. 0x7F) .|. (rest `shiftL` 7)
-
-putULEB128 :: (Integral a, Bits a) => a -> Put
-putULEB128 val =
-    if val < 128
-    then putWord8 $ fromIntegral val
-    else do
-        putWord8 $ 0x80 + (0x7F .&. fromIntegral val)
-        putULEB128 $ val `shiftR` 7
-
-getSLEB128 :: (Integral a, Bits a) => Int -> Get a
-getSLEB128 bitsBudget = do
-    if bitsBudget > 0 then return () else fail "integer representation too long"
-    let toInt8 :: Word8 -> Int8
-        toInt8 = fromIntegral
-    a <- getWord8
-    let mask = (0xFF `shiftL` (bitsBudget - 1)) .&. 0x7F
-    if bitsBudget >= 7 || a .&. mask == 0 || a .&. mask == mask then return () else fail "integer too large"
-    if not (testBit a 7)
-    then return . fromIntegral . toInt8 $ (a .&. 0x7f) .|. ((a .&. 0x40) `shiftL` 1)
-    else do
-        b <- getSLEB128 (bitsBudget - 7)
-        return $ (b `shiftL` 7) .|. (fromIntegral (a .&. 0x7f))
-
-putSLEB128 :: (Integral a, Bits a) => a -> Put
-putSLEB128 a = go a
-    where
-        ext = if a >= 0 then 0 else complement 0
-        go x = do
-            let 
-                r = x `shiftR` 7
-                w = x .&. 0x7f
-            if r /= ext
-            then do
-                putWord8 (fromIntegral w .|. 0x80)
-                go r
-            else
-                if (testBit w 6 && a < 0) || (not (testBit w 6) && a >= 0)
-                then putWord8 (fromIntegral w)
-                else do
-                    putWord8 (fromIntegral w .|. 0x80)
-                    putWord8 (fromIntegral ext .&. 0x7F)
-
-
-
-putSection :: SectionId -> Put -> Put
-putSection i contents =
-  unless (len == 0) $ do
-    put i
-    put (lengthOf each contents')
-    put contents'
-  where
-    contents' = runPut contents
-    len = lengthOf each contents'
-
-putU32 :: Word32 -> Put
-putU32 = putULEB128
-
-putI32 :: Int32 -> Put
-putI32 = putSLEB128
-
-putList :: Foldable f => (a -> Put) -> f a -> Put
-putList f xs = do
-  putU32 (fromIntegral $ length xs)
-  traverse_ f xs
-
-
-
-putTypeSection :: Vector Type -> Put
-putTypeSection = putSection SectionType . putList put
-
-putCodeSection :: Vector Type -> Put
-putCodeSection = putSection SectionType . putList put
-
-putStartSection :: Maybe FuncIdx -> Put
-putStartSection (Just x) = put x
-putStartSection Nothing = pure ()
-
-instance Binary Module where
-  get = _
-  put m = do
-    -- magic
-    traverse_ putWord8 [0x00, 0x61, 0x73, 0x6d]
-    -- version
-    traverse_ putWord8 [0x01, 0x00, 0x00, 0x00]
-    -- sections
-    putTypeSection m.types
-    putStartSection m.start
-
-instance Binary RecType where
-  get = _
-  put rt = case rt.subtypes of
-    [st] -> put st
-    sts -> do
-      putWord8 0x4e
-      putList put sts
-
-instance Binary SubType where
-  get = _
-  put st = do
-    putWord8 $ if st.final then 0x4f else 0x50
-    putList put st.supertypes
-    put st.ct
-
-instance Binary CompType where
-  get = _
-  put = \case
-    CompTypeFunc s t -> do
-      putWord8 0x60
-      traverseOf_ both (putList put) (s,t)
-
-instance Binary ValType where
-  put = \case
-    ValTypeNum nt -> put nt
-
-instance Binary NumType where
-  get = _
-  put = putWord8 . \case
-    F64 -> 0x7c
-    F32 -> 0x7d
-    I64 -> 0x7e
-    I32 -> 0x7f
-
-instance Binary Idx where
-  get = _
-  put = putU32 . coerce

gyehoek.cabal

@@ -43,7 +43,7 @@ executable gyehoek
     Gyehoek.Options
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
-    Gyehoek.Wasm.Syntax
+    Gyehoek.Wasm
 
   build-depends:
     , base                  ^>=4.21.2.0