tests
This commit is contained in:
@@ -1,49 +0,0 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
module Gyehoek.CPS.Convert
|
||||
( convert
|
||||
) where
|
||||
|
||||
import Gyehoek.CPS.Syntax
|
||||
import Gyehoek.Scheme.Syntax qualified as Scm
|
||||
import Gyehoek.GenSym
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import Effectful
|
||||
import Control.Monad.Cont qualified as Cont
|
||||
|
||||
|
||||
-- 뻘짓이어라
|
||||
telescope
|
||||
:: Traversable t
|
||||
=> (a -> (b -> r) -> r)
|
||||
-> t a -> (t b -> r) -> r
|
||||
telescope f = Cont.runCont . traverse (Cont.cont . f)
|
||||
|
||||
convert
|
||||
:: forall es. (GenSym :> es)
|
||||
=> Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
|
||||
|
||||
convert (Scm.ExpVar x) k = k $ ValVar x
|
||||
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] <$> k (ValVar r)
|
||||
|
||||
convert (Scm.ExpLambda xs e) k = do
|
||||
f <- gensym' "f"
|
||||
ktail <- gensym' "ktail"
|
||||
m <- convert e $ \e' ->
|
||||
pure $ ExpApply (ValVar ktail) [e']
|
||||
ExpFix [(f, MkKappa (xs ++ [ktail]) m)] <$> k (ValVar f)
|
||||
|
||||
convert (Scm.ExpApply f xs) k =
|
||||
telescope (convert @es) (f:|xs) \(f':|xs') -> do
|
||||
r <- gensym' "r"
|
||||
x <- gensym' "x"
|
||||
m <- k (ValVar x)
|
||||
pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r])
|
||||
|
||||
convert (Scm.ExpBegin xs) k = _
|
||||
|
||||
convert _ k = _
|
||||
@@ -1,97 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE MultilineStrings #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
|
||||
module Gyehoek.CPS.Lower
|
||||
(
|
||||
lower) where
|
||||
|
||||
import Gyehoek.CPS.Syntax
|
||||
import Data.Generics.Labels
|
||||
import Gyehoek.Scheme.Syntax qualified as Scm
|
||||
import Gyehoek.GenSym
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import Effectful
|
||||
import Control.Monad.Cont qualified as Cont
|
||||
import Effectful.Writer.Static.Local
|
||||
import Data.Text (Text)
|
||||
import Data.Vector.Strict (Vector)
|
||||
import Control.Lens
|
||||
import Data.Foldable
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Numeric.Natural
|
||||
import GHC.Generics (Generic)
|
||||
import Gyehoek.Scheme.Syntax (Lit(LitInt))
|
||||
import Text.Printf
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector.Strict as V
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import Data.String.Interpolate
|
||||
import Gyehoek.Wasm qualified as Wasm
|
||||
import Gyehoek.Wasm (i32, ins, sxp)
|
||||
|
||||
|
||||
data Env = MkEnv { vars :: Vector Name }
|
||||
deriving (Show, Generic)
|
||||
|
||||
emptyEnv :: Env
|
||||
emptyEnv = MkEnv mempty
|
||||
|
||||
type instance Index Env = Natural
|
||||
type instance IxValue Env = Name
|
||||
|
||||
instance Ixed Env where
|
||||
ix i = #vars . ix (fromIntegral i)
|
||||
|
||||
|
||||
|
||||
tshow :: Show a => a -> Text
|
||||
tshow = T.pack . show
|
||||
|
||||
|
||||
|
||||
lowerVal :: Env -> Val -> Wasm.Expr
|
||||
|
||||
lowerVal g (ValLit l) =
|
||||
case l of
|
||||
LitInt n -> [ ins "i32.const" [sxp n] ]
|
||||
_ -> _
|
||||
|
||||
lowerVal g (ValVar x) = [ ins "local.get" [sxp l] ]
|
||||
where
|
||||
l = V.elemIndex x g.vars ^?! _Just
|
||||
|
||||
lower' :: Env -> Exp -> Wasm.Expr
|
||||
|
||||
lower' g (Halt [e]) = lowerVal g e
|
||||
|
||||
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
|
||||
|
||||
lowerBinOp
|
||||
:: _
|
||||
-> _ -> _ -> _ -> _ -> _ -> Wasm.Expr
|
||||
lowerBinOp op g x y r e =
|
||||
lowerVal g x
|
||||
<> lowerVal g y
|
||||
<> [ ins op [] ]
|
||||
<> [ ins "local.set" [sxp n] ]
|
||||
<> lower' g' e
|
||||
where
|
||||
g' = g & #vars <>~ [r]
|
||||
n = length (g ^. #vars)
|
||||
|
||||
|
||||
|
||||
lower :: Exp -> Eff es Text
|
||||
lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
|
||||
idx <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ ->
|
||||
lower' emptyEnv e
|
||||
Wasm.export "main" "func" idx
|
||||
@@ -1,97 +0,0 @@
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Gyehoek.CPS.Syntax
|
||||
( Val(..)
|
||||
, Kappa(..)
|
||||
, Exp(..)
|
||||
, Name(..)
|
||||
, Prim(..)
|
||||
, pattern Halt
|
||||
, pattern Halt1
|
||||
, _MkKappa
|
||||
, _ExpPrim
|
||||
, _ExpFix
|
||||
, _ExpApply
|
||||
)
|
||||
where
|
||||
|
||||
import Language.SexpGrammar qualified as S
|
||||
import Gyehoek.Sexp qualified
|
||||
import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit)
|
||||
import Data.Text (Text)
|
||||
import Data.List (List)
|
||||
import GHC.Generics (Generic)
|
||||
import Language.SexpGrammar.Generic
|
||||
import Control.Category
|
||||
import Control.Lens
|
||||
import Data.Text qualified as T
|
||||
import Data.Generics.Labels
|
||||
import Prelude hiding ((.), id)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
|
||||
-- Data types
|
||||
|
||||
data Val
|
||||
= ValLabel Name
|
||||
| ValVar Name
|
||||
| ValLit Lit
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Kappa = MkKappa (List Name) Exp
|
||||
deriving (Show, Generic)
|
||||
|
||||
data 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
|
||||
pattern Halt xs = ExpApply (ValVar "halt") xs
|
||||
|
||||
pattern Halt1 :: Val -> Exp
|
||||
pattern Halt1 x = ExpApply (ValVar "halt") [x]
|
||||
|
||||
makePrisms ''Kappa
|
||||
makePrisms ''Exp
|
||||
|
||||
|
||||
-- SexpIso instances
|
||||
|
||||
instance S.SexpIso Val where
|
||||
sexpIso = match
|
||||
$ With (. label)
|
||||
$ With (. var)
|
||||
$ With (. S.sexpIso)
|
||||
$ End
|
||||
where
|
||||
label = S.keyword >>> S.iso MkName getName
|
||||
var = S.sexpIso
|
||||
|
||||
instance S.SexpIso Kappa where
|
||||
sexpIso = match
|
||||
$ With (. kappa)
|
||||
$ End
|
||||
where
|
||||
kappa = S.list $
|
||||
S.el Gyehoek.Sexp.kappaKeyword
|
||||
>>> S.el (S.list $ S.rest S.sexpIso)
|
||||
>>> S.el S.sexpIso
|
||||
|
||||
instance S.SexpIso Exp where
|
||||
sexpIso = match
|
||||
$ 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.el S.sexpIso
|
||||
@@ -1,45 +0,0 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Gyehoek.GenSym where
|
||||
|
||||
import Numeric.Natural
|
||||
import Effectful.State.Dynamic
|
||||
import Effectful.Dispatch.Dynamic
|
||||
import Effectful
|
||||
import Data.String (IsString(fromString))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.Short as ST
|
||||
|
||||
|
||||
class Gen a where
|
||||
gen :: Natural -> a
|
||||
gen' :: Text -> Natural -> a
|
||||
|
||||
data GenSym :: Effect where
|
||||
GenSym :: Gen a => GenSym m a
|
||||
GenSym' :: Gen a => Text -> GenSym m a
|
||||
|
||||
type instance DispatchOf GenSym = Dynamic
|
||||
|
||||
gensym :: forall a es. (Gen a, GenSym :> es) => Eff es a
|
||||
gensym = send GenSym
|
||||
|
||||
gensym' :: forall a es. (Gen a, GenSym :> es) => Text -> Eff es a
|
||||
gensym' = send . GenSym'
|
||||
|
||||
runGenSym :: Eff (GenSym : es) a -> Eff es a
|
||||
runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \cases
|
||||
_ GenSym -> state \n -> (gen n, succ n)
|
||||
_ (GenSym' s) -> state \n -> (gen' s n, succ n)
|
||||
|
||||
instance Gen Text where
|
||||
gen = fromString . ('x':) . show
|
||||
gen' s = (s <>) . fromString . show
|
||||
|
||||
instance Gen Natural where
|
||||
gen = id
|
||||
gen' = const id
|
||||
|
||||
instance Gen Int where
|
||||
gen = fromIntegral
|
||||
gen' _ = fromIntegral
|
||||
@@ -1,51 +0,0 @@
|
||||
{-# LANGUAGE NoFieldSelectors #-}
|
||||
module Gyehoek.Options
|
||||
( Options(..)
|
||||
, parser
|
||||
)
|
||||
where
|
||||
|
||||
import System.IO (Handle)
|
||||
import Data.HashSet (HashSet)
|
||||
import Options.Applicative
|
||||
import System.FilePath
|
||||
import qualified Data.HashSet as HS
|
||||
import Control.Lens hiding (argument)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
|
||||
data Options = MkOptions
|
||||
{ -- dumpANF :: Maybe FilePath
|
||||
-- , dumpQBE :: Maybe FilePath
|
||||
output :: FilePath
|
||||
, sourceFile :: FilePath
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
-- osPath :: ReadM _
|
||||
-- osPath = eitherReader $
|
||||
-- (_Left %~ show) . encodeUtf @(Either _)
|
||||
|
||||
-- parseDumpQBE =
|
||||
-- optional $ strOption
|
||||
-- ( long "dump-qbe"
|
||||
-- <> metavar "FILE"
|
||||
-- )
|
||||
|
||||
-- parseDumpANF =
|
||||
-- optional $ strOption
|
||||
-- ( long "dump-anf"
|
||||
-- <> metavar "FILE"
|
||||
-- )
|
||||
|
||||
parseOutput = strOption
|
||||
( long "output"
|
||||
<> short 'o'
|
||||
<> metavar "FILE"
|
||||
<> value "-"
|
||||
)
|
||||
|
||||
parser :: Parser Options
|
||||
parser = MkOptions
|
||||
<$> parseOutput
|
||||
<*> argument str (metavar "FILE")
|
||||
@@ -1,166 +0,0 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE OrPatterns #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
module Gyehoek.Scheme.Syntax
|
||||
( Name(..)
|
||||
, Prim(..)
|
||||
, Lit(..)
|
||||
, Define(..)
|
||||
, Exp(..)
|
||||
, Sexp(..)
|
||||
, primSexpIso
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.List (List)
|
||||
import Language.SexpGrammar
|
||||
( SexpIso(..), list, el, (>>>), rest, sym, symbol )
|
||||
import Language.SexpGrammar qualified as Sexp
|
||||
import Language.SexpGrammar.Generic
|
||||
import GHC.Generics
|
||||
import Prelude hiding ((.), id)
|
||||
import Control.Category
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import Gyehoek.Sexp qualified
|
||||
import Gyehoek.GenSym (Gen)
|
||||
import Control.Lens (Each)
|
||||
import Data.String (IsString)
|
||||
import Data.Hashable (Hashable)
|
||||
|
||||
|
||||
newtype Name = MkName { getName :: Text }
|
||||
deriving newtype (Show, Eq, IsString, Gen, Hashable)
|
||||
deriving stock (Generic)
|
||||
|
||||
data Prim e
|
||||
= PrimAdd e e
|
||||
| PrimSub e e
|
||||
| PrimMul e e
|
||||
| PrimDiv e e
|
||||
| PrimCons e e
|
||||
| PrimCar e
|
||||
| PrimCdr e
|
||||
| PrimImmediateP e
|
||||
| PrimConsP e
|
||||
| PrimIntegerP e
|
||||
| PrimWrite e
|
||||
| PrimZeroP e
|
||||
| PrimNewline
|
||||
deriving (Show, Generic, Functor, Foldable, Traversable)
|
||||
|
||||
instance Each (Prim e) (Prim e') e e'
|
||||
|
||||
data Lit
|
||||
= LitInt Int
|
||||
| LitNil
|
||||
| LitBool Bool
|
||||
| LitString Text
|
||||
| LitQuote Sexp
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Define
|
||||
= DefineConstant Name Exp
|
||||
| DefineProcedure Name (List Name) (List Exp)
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Exp
|
||||
= ExpLet (NonEmpty (Name, Exp)) Exp
|
||||
| ExpPrim (Prim Exp)
|
||||
| ExpBegin (List Exp)
|
||||
| ExpDefine Define
|
||||
| ExpIf Exp Exp Exp
|
||||
| ExpLit Lit
|
||||
| ExpLambda (List Name) Exp
|
||||
| ExpVar Name
|
||||
| ExpApply Exp (List Exp)
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Sexp
|
||||
= SexpCons Sexp Sexp
|
||||
| SexpSymbol Text
|
||||
| SexpLit Lit
|
||||
deriving (Show, Generic)
|
||||
|
||||
|
||||
|
||||
instance SexpIso Name where
|
||||
sexpIso = symbol >>> Sexp.partialOsi f g
|
||||
where
|
||||
f = Right . MkName
|
||||
g (MkName s) = s
|
||||
|
||||
primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
|
||||
primSexpIso namefn a = match
|
||||
$ With (. binop "+")
|
||||
$ With (. binop "-")
|
||||
$ With (. binop "*")
|
||||
$ With (. binop "/")
|
||||
$ With (. binop "cons")
|
||||
$ With (. unop "car")
|
||||
$ With (. unop "cdr")
|
||||
$ With (. unop "immediate?")
|
||||
$ With (. unop "cons?")
|
||||
$ With (. unop "integer?")
|
||||
$ With (. unop "write")
|
||||
$ With (. unop "zero?")
|
||||
$ With (. nullop "newline")
|
||||
$ End
|
||||
where
|
||||
idn s = el (sym (namefn s))
|
||||
nullop s = list $ idn s
|
||||
unop s = list $ idn s >>> el a
|
||||
binop s = list $ idn s >>> el a >>> el a
|
||||
|
||||
instance SexpIso a => SexpIso (Prim a) where
|
||||
-- sexpIso = primSexpIso ("prim:"<>) sexpIso
|
||||
sexpIso = primSexpIso id sexpIso
|
||||
|
||||
instance SexpIso Lit where
|
||||
sexpIso = match
|
||||
$ With (. sexpIso)
|
||||
$ With (. sym "nil")
|
||||
$ With (. sexpIso)
|
||||
$ With (. sexpIso)
|
||||
$ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
|
||||
$ End
|
||||
|
||||
instance SexpIso Sexp where
|
||||
sexpIso = match
|
||||
$ With (\cons -> cons . Gyehoek.Sexp.todo)
|
||||
$ With (\s -> s . symbol)
|
||||
$ With (\lit -> lit . sexpIso)
|
||||
$ End
|
||||
|
||||
instance SexpIso Define where
|
||||
sexpIso = match
|
||||
$ With (. defconst)
|
||||
$ With (. defun)
|
||||
$ End
|
||||
where
|
||||
defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
|
||||
defun = list $ el (sym "define") >>> el args >>> rest sexpIso
|
||||
args = list $ el sexpIso >>> rest sexpIso
|
||||
|
||||
instance SexpIso Exp where
|
||||
sexpIso = match
|
||||
$ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
|
||||
$ With (. sexpIso)
|
||||
$ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
|
||||
$ With (. sexpIso)
|
||||
$ With (. if_)
|
||||
$ With (. sexpIso)
|
||||
$ With (. lam)
|
||||
$ With (. sexpIso)
|
||||
$ With (\app -> app . list (el sexpIso >>> rest sexpIso))
|
||||
$ End
|
||||
where
|
||||
if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
|
||||
lam = list
|
||||
( el Gyehoek.Sexp.lambdaKeyword
|
||||
>>> el (sexpIso @(List Name))
|
||||
>>> el sexpIso )
|
||||
@@ -1,152 +0,0 @@
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
module Gyehoek.Sexp
|
||||
( let_
|
||||
, sexp
|
||||
, nonempty
|
||||
, nonEmptyGrammar
|
||||
, encode
|
||||
, decode
|
||||
, parseSexps
|
||||
, prefixSugar
|
||||
, todo
|
||||
, isoIso
|
||||
, encodeWith
|
||||
, decodeWith
|
||||
, kappa
|
||||
, lambda
|
||||
, kappaKeyword
|
||||
, lambdaKeyword
|
||||
, encodePrettyWith
|
||||
, encodePretty
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
|
||||
import Language.SexpGrammar qualified as Sexp
|
||||
import Language.Sexp qualified as S
|
||||
import Language.SexpGrammar.Generic
|
||||
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.Text.Encoding
|
||||
import Data.Either (either)
|
||||
import GHC.Generics (Generic)
|
||||
import Control.Lens
|
||||
import Data.Generics.Labels
|
||||
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 Data.Void (absurd)
|
||||
|
||||
|
||||
sexp :: SexpIso a => Iso' a Text
|
||||
sexp = iso
|
||||
(either error id . encode)
|
||||
(either error id . decode)
|
||||
|
||||
encode :: SexpIso a => a -> Either String Text
|
||||
encode = encodeWith sexpIso
|
||||
|
||||
decode :: SexpIso a => Text -> Either String a
|
||||
decode = decodeWith sexpIso
|
||||
|
||||
encodeWith :: SexpGrammar a -> a -> Either String Text
|
||||
encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g
|
||||
|
||||
encodePretty :: SexpIso a => a -> Either String Text
|
||||
encodePretty = encodePrettyWith sexpIso
|
||||
|
||||
decodeWith :: SexpGrammar a -> Text -> Either String a
|
||||
decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
|
||||
|
||||
encodePrettyWith :: SexpGrammar a -> a -> Either String Text
|
||||
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
|
||||
where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
|
||||
|
||||
nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
|
||||
nonEmptyGrammar = IGB.Iso
|
||||
(\((x:|xs) :- t) -> reverse xs :- x :- t)
|
||||
(\(xs :- x :- t) -> (x :| reverse xs) :- t)
|
||||
|
||||
nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
|
||||
nonempty a =
|
||||
list (el a >>> rest a) >>>
|
||||
IG.flipped nonEmptyGrammar
|
||||
|
||||
let_
|
||||
:: Text
|
||||
-> (forall t. Grammar Position (Sexp :- t) (a :- t))
|
||||
-> (forall t. Grammar Position (Sexp :- t) (b :- t))
|
||||
-> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
|
||||
-> Grammar Position (Sexp :- t1) t2
|
||||
let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
|
||||
where
|
||||
-- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
|
||||
bindings = nonempty binding
|
||||
binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
|
||||
binding = list (el name >>> el rhs) >>> pair
|
||||
|
||||
data DotList a = MkDotList (NonEmpty a) a
|
||||
deriving (Show, Generic)
|
||||
|
||||
dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
|
||||
dotlist x = list $ rest $ coproduct
|
||||
[ x >>> _
|
||||
]
|
||||
|
||||
-- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
|
||||
prefixSugar
|
||||
:: Text -> Prefix
|
||||
-> Grammar Position (Sexp :- t') a
|
||||
-> Grammar Position (Sexp :- t') a
|
||||
prefixSugar name prefix e = coproduct
|
||||
-- 'something
|
||||
[ Sexp.prefixed prefix e
|
||||
-- (quote something)
|
||||
, list $ el (sym name) >>> el e
|
||||
]
|
||||
|
||||
todo :: Grammar p (Sexp :- t) t'
|
||||
todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
|
||||
where
|
||||
f _ = Left $ unexpected "todo"
|
||||
g _ = Left $ unexpected "todo"
|
||||
|
||||
kappa
|
||||
:: (forall t. Grammar Position (Sexp :- t) (a :- t))
|
||||
-> Grammar Position (Sexp :- List a :- t1) t2
|
||||
-> Grammar Position (Sexp :- t1) t2
|
||||
kappa name e = list $
|
||||
el kappaKeyword
|
||||
>>> el (list $ rest name)
|
||||
>>> el e
|
||||
|
||||
lambda
|
||||
:: (forall t. Grammar Position (Sexp :- t) (a :- t))
|
||||
-> Grammar Position (Sexp :- List a :- t1) t2
|
||||
-> Grammar Position (Sexp :- t1) t2
|
||||
lambda name e = list $
|
||||
el lambdaKeyword
|
||||
>>> el (list $ rest name)
|
||||
>>> el e
|
||||
|
||||
isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
|
||||
isoIso l = Sexp.iso (view l) (review l)
|
||||
|
||||
kappaKeyword :: Grammar Position (Sexp :- t) t
|
||||
kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
|
||||
|
||||
lambdaKeyword :: Grammar Position (Sexp :- t) t
|
||||
lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]
|
||||
@@ -1,218 +0,0 @@
|
||||
{- 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 #-}
|
||||
module Gyehoek.Wasm
|
||||
( defun
|
||||
, deftype
|
||||
, start
|
||||
, runGenMod
|
||||
, execGenMod
|
||||
, renderModule
|
||||
, Module
|
||||
, Function
|
||||
, Expr
|
||||
, Instr
|
||||
, GenMod
|
||||
, i32
|
||||
, export
|
||||
, ins
|
||||
, sxp
|
||||
)
|
||||
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)
|
||||
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)
|
||||
|
||||
sxp :: SexpIso a => a -> Sexp
|
||||
sxp e = Sexp.toSexp sexpIso e ^?! _Right
|
||||
|
||||
ins :: Text -> List Sexp -> Instr
|
||||
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
|
||||
+3
-81
@@ -1,84 +1,6 @@
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE OrPatterns #-}
|
||||
module Main
|
||||
(main)
|
||||
where
|
||||
module Main (main) where
|
||||
|
||||
import Gyehoek.Options
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Data.Text (Text)
|
||||
import Prelude hiding (readFile)
|
||||
import Options.Applicative
|
||||
import Control.Lens
|
||||
import Data.Generics.Labels
|
||||
import System.OsPath (OsPath)
|
||||
import System.FilePath ((-<.>), dropExtension)
|
||||
import Effectful.FileSystem
|
||||
import Effectful
|
||||
import Effectful.FileSystem.IO qualified as FS
|
||||
import Effectful.FileSystem.IO.ByteString qualified as FB
|
||||
import Gyehoek.GenSym (runGenSym, GenSym, gensym, gensym')
|
||||
import qualified Gyehoek.Sexp as Sexp
|
||||
import Data.Text.Lens
|
||||
import Data.List (List)
|
||||
import qualified Gyehoek.Scheme.Syntax as Scm
|
||||
import Effectful.Exception
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import System.IO (Handle)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Cradle as C
|
||||
import Gyehoek.CPS.Convert
|
||||
import Gyehoek.CPS.Lower
|
||||
import Data.Foldable
|
||||
import qualified Gyehoek.Scheme.Syntax
|
||||
import Gyehoek.CPS.Syntax
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Gyehoek.Driver qualified
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- execParser $ info (helper <*> parser) fullDesc
|
||||
runEff . runFileSystem . runGenSym . driver $ opts
|
||||
|
||||
|
||||
|
||||
hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
|
||||
hPutStr h = FB.hPutStr h . T.encodeUtf8
|
||||
|
||||
hPutStrLn :: FileSystem :> es => Handle -> Text -> Eff es ()
|
||||
hPutStrLn h = FB.hPutStrLn h . T.encodeUtf8
|
||||
|
||||
hGetContents :: FileSystem :> es => Handle -> Eff es Text
|
||||
hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
|
||||
|
||||
readFile :: FileSystem :> es => FilePath -> Eff es Text
|
||||
readFile f = FS.withFile f FS.ReadMode hGetContents
|
||||
|
||||
withFile
|
||||
:: (FileSystem :> es)
|
||||
=> FilePath -> FS.IOMode -> (Handle -> Eff es a) -> Eff es a
|
||||
withFile "-" FS.ReadMode k = k FS.stdin
|
||||
withFile "-" (FS.WriteMode; FS.AppendMode) k = k FS.stdout
|
||||
withFile f m k = FS.withFile f m k
|
||||
|
||||
readScm :: FileSystem :> es => FilePath -> Eff es Scm.Exp
|
||||
readScm f =
|
||||
withFile f FS.ReadMode $ \h ->
|
||||
Sexp.parseSexps f <$> hGetContents h
|
||||
>>= either error wrap
|
||||
where
|
||||
wrap [x] = pure x
|
||||
wrap xs = pure . Gyehoek.Scheme.Syntax.ExpBegin $ xs
|
||||
|
||||
driver
|
||||
:: (GenSym :> es, FileSystem :> es, IOE :> es)
|
||||
=> Options -> Eff es ()
|
||||
driver opts = do
|
||||
scm <- readScm opts.sourceFile
|
||||
cps <- convert scm (pure . Halt1)
|
||||
wat <- lower cps
|
||||
withFile opts.output FS.WriteMode \h ->
|
||||
hPutStr h wat
|
||||
main = Gyehoek.Driver.main
|
||||
|
||||
Reference in New Issue
Block a user