tests
This commit is contained in:
@@ -0,0 +1,257 @@
|
||||
{- HLINT ignore "Use newtype instead of data" -}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DeepSubsumption #-}
|
||||
{-# LANGUAGE NoFieldSelectors #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE ImpredicativeTypes #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
module Gyehoek.Wasm
|
||||
( defun
|
||||
, deftype
|
||||
, start
|
||||
, runGenMod
|
||||
, execGenMod
|
||||
, renderModule
|
||||
, Module
|
||||
, Function
|
||||
, Expr
|
||||
, Instr
|
||||
, GenMod
|
||||
, i32
|
||||
, export
|
||||
, ins
|
||||
, sxp
|
||||
, result
|
||||
, param
|
||||
, if'
|
||||
)
|
||||
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)
|
||||
|
||||
|
||||
data Module = MkModule
|
||||
{ types :: Vector Type
|
||||
, functions :: Vector Function
|
||||
, start :: Maybe Idx
|
||||
, exports :: Vector Export
|
||||
}
|
||||
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
|
||||
}
|
||||
|
||||
instance Monoid Module where
|
||||
mempty = MkModule mempty mempty Nothing mempty
|
||||
|
||||
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 }
|
||||
deriving (Show, Generic)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
newtype Instr = MkInstr { inner :: Sexp }
|
||||
deriving (Show, Generic)
|
||||
|
||||
newtype Type = MkType { inner :: Sexp }
|
||||
deriving (Show, Generic)
|
||||
|
||||
newtype Idx = MkIdx { getIdx :: Natural }
|
||||
deriving newtype (Show)
|
||||
|
||||
data GenMod :: Effect where
|
||||
DefType :: Type -> GenMod m Idx
|
||||
Defun :: List Type -> List Type -> List Type -> (Idx -> Expr) -> GenMod m Idx
|
||||
Start :: Idx -> GenMod m ()
|
||||
Export :: Text -> Text -> 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
|
||||
|
||||
deftype :: (GenMod :> es) => Type -> Eff es Idx
|
||||
deftype = send . DefType
|
||||
|
||||
defun
|
||||
:: (GenMod :> es)
|
||||
=> List Type -> List Type -> List Type
|
||||
-> (Idx -> Expr)
|
||||
-> Eff es Idx
|
||||
defun params result locals code = send $ Defun params result locals code
|
||||
|
||||
-- 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 :: Eff (GenMod : es) a -> Eff es (a, Module)
|
||||
runGenMod =
|
||||
reinterpret (runStateLocal (mempty :: Module)) \cases
|
||||
_ (DefType t) -> state \m ->
|
||||
( MkIdx . fromIntegral . length $ m.types
|
||||
, m & #types <>~ V.singleton t
|
||||
)
|
||||
_ (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 ] ]
|
||||
_ (Defun params result locals code) -> state \m ->
|
||||
let idx = MkIdx . fromIntegral . length $ m.functions
|
||||
in ( idx
|
||||
, m & #functions <>~ V.singleton
|
||||
(MkFunction params result locals (code idx))
|
||||
)
|
||||
|
||||
execGenMod = fmap snd . runGenMod
|
||||
|
||||
renderModule :: Module -> Text
|
||||
renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
|
||||
|
||||
i32 :: Type
|
||||
i32 = MkType $ Symbol "i32"
|
||||
|
||||
|
||||
|
||||
instance SexpIso Idx where
|
||||
sexpIso = Sexp.integer >>> Sexp.partialOsi f g
|
||||
where
|
||||
f n | n < 0 = Left $ Sexp.unexpected "negative" <> Sexp.expected "natural"
|
||||
| otherwise = Right . MkIdx $ fromIntegral n
|
||||
g (MkIdx n) = fromIntegral n
|
||||
|
||||
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
|
||||
|
||||
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))
|
||||
>>> rest (sexpIso @Instr)
|
||||
>>> Sexp.onTail
|
||||
(Sexp.iso
|
||||
(view instrsExpr)
|
||||
(review instrsExpr))
|
||||
)
|
||||
>>> func
|
||||
where
|
||||
instrsExpr :: Iso' (List Instr) Expr
|
||||
instrsExpr = vector . coerced
|
||||
|
||||
instance SexpIso Module where
|
||||
sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->
|
||||
ParenList $
|
||||
[ Symbol "module" ]
|
||||
<> (m ^.. #types . each . #inner)
|
||||
<> (m ^.. #functions . each . to sxp)
|
||||
<> (m ^.. #exports . each . to sxp)
|
||||
|
||||
instance Each Expr Expr Instr Instr where
|
||||
each = #MkExpr . each
|
||||
|
||||
sxp :: SexpIso a => a -> Sexp
|
||||
sxp e = Sexp.toSexp sexpIso e ^?! _Right
|
||||
|
||||
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) ]
|
||||
Reference in New Issue
Block a user