driverslop

app/Gyehoek/CPS/Convert.hs

@@ -44,4 +44,6 @@ convert (Scm.ExpApply f xs) k =
     m <- k (ValVar x)
     pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r])
 
+convert (Scm.ExpBegin xs) k = _
+
 convert _ k = _

app/Gyehoek/CPS/Lower.hs

@@ -5,8 +5,8 @@
 {-# LANGUAGE MultilineStrings #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.CPS.Lower
-  ( lower
+  (
-  ) where
+  lower) where
 
 import Gyehoek.CPS.Syntax
 import Data.Generics.Labels
@@ -27,6 +27,7 @@ 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)
 
 
 type Emit = Writer (Vector Text)
@@ -64,6 +65,18 @@ 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) =
@@ -75,11 +88,11 @@ lowerVal g (ValVar x) = [ "local.get " <> tshow i ]
   where
     i = V.elemIndex x g.vars ^?! _Just
 
-lower :: Env -> Exp -> Vector Text
+lower' :: Env -> Exp -> Vector Text
 
-lower g (Halt [e]) = lowerVal g e
+lower' g (Halt [e]) = lowerVal g e
 
-lower g (ExpPrim p rs es) =
+lower' g (ExpPrim p rs es) =
   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
@@ -91,7 +104,7 @@ lowerBinOp op g x y r e =
   lowerVal g x
   <> lowerVal g y
   <> [ op, "local.set " <> tshow n ]
-  <> lower g' e
+  <> lower' g' e
   where
     g' = g & #vars <>~ [r]
     n = length (g ^. #vars)
@@ -106,3 +119,6 @@ makeFunc = (preamble<>) . (<>postamble) . T.unlines . toList . fmap indent
                 \  (func (export \"main\") (result i32)\n\
                 \    (local i32 i32 i32 i32 i32 i32)\n"
     postamble = "  ))"
+
+lower :: Exp -> Eff es Text
+lower = pure . makeFunc . lower' emptyEnv

app/Gyehoek/Options.hs

@@ -17,8 +17,8 @@ import GHC.Generics (Generic)
 data Options = MkOptions
   { -- dumpANF :: Maybe FilePath
   -- , dumpQBE :: Maybe FilePath
-  output :: Maybe FilePath
+  output :: FilePath
-  , sourceFiles :: HashSet FilePath
+  , sourceFile :: FilePath
   }
   deriving (Show, Generic)
 
@@ -38,14 +38,14 @@ data Options = MkOptions
 --     <> metavar "FILE"
 --     )
 
-parseOutput =
+parseOutput = strOption
-  optional $ strOption
     ( long "output"
     <> short 'o'
     <> metavar "FILE"
+    <> value "-"
     )
 
 parser :: Parser Options
 parser = MkOptions
   <$> parseOutput
-  <*> (HS.fromList <$> some (argument str (metavar "FILES")))
+  <*> argument str (metavar "FILE")

app/Gyehoek/Scheme/Syntax.hs

@@ -117,7 +117,8 @@ primSexpIso namefn a = match
       binop s = list $ idn s >>> el a >>> el a
 
 instance SexpIso a => SexpIso (Prim a) where
-  sexpIso = primSexpIso ("prim:"<>) sexpIso
+  -- sexpIso = primSexpIso ("prim:"<>) sexpIso
+  sexpIso = primSexpIso id sexpIso
 
 instance SexpIso Lit where
   sexpIso = match

app/Gyehoek/Wasm/Build.hs

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

app/Main.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OrPatterns #-}
 module Main
   (main)
   where
@@ -8,7 +9,7 @@ module Main
 import Gyehoek.Options
 import qualified Data.Text.IO as TIO
 import Data.Text (Text)
-import Prelude hiding (readFile, (.),id)
+import Prelude hiding (readFile)
 import Options.Applicative
 import Control.Lens
 import Data.Generics.Labels
@@ -29,6 +30,12 @@ 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)
 
 
 main :: IO ()
@@ -50,10 +57,28 @@ hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
 readFile :: FileSystem :> es => FilePath -> Eff es Text
 readFile f = FS.withFile f FS.ReadMode hGetContents
 
-readScm :: FileSystem :> es => FilePath -> Eff es (List Scm.Exp)
+withFile
-readScm f = (Sexp.parseSexps f <$> readFile f) >>= either error pure
+  :: (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 = _
+driver opts = do
+  scm <- readScm opts.sourceFile
+  cps <- convert scm (pure . Halt1)
+  wat <- lower cps
+  withFile opts.output FS.WriteMode \h ->
+    hPutStr h wat

example/arith.scm

@@ -0,0 +1 @@
+(+ (* 3 4) (* 2 5))

gyehoek.cabal

@@ -25,6 +25,7 @@ common ghcstuffs
   default-extensions:
     BlockArguments
     DeriveGeneric
+    OverloadedRecordDot
     OverloadedStrings
     PartialTypeSignatures
     PatternSynonyms