app/Gyehoek/Options.hs

@@ -8,7 +8,10 @@ module Gyehoek.Options
 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
@@ -17,7 +20,11 @@ data Options = MkOptions
   output :: Maybe FilePath
   , sourceFiles :: HashSet FilePath
   }
-  deriving (Show)
+  deriving (Show, Generic)
+
+-- osPath :: ReadM _
+-- osPath = eitherReader $
+--   (_Left %~ show) . encodeUtf @(Either _)
 
 -- parseDumpQBE =
 --   optional $ strOption

app/Gyehoek/Scheme/Syntax.hs

@@ -40,10 +40,17 @@ data Lit
   | LitBool Bool
   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
   | ExpApply Exp (List Exp)
   | ExpLambda (List Name) Exp
@@ -78,17 +85,30 @@ instance SexpIso Lit where
     $ With (. sexpIso)
     $ End
 
+instance SexpIso Define where
+  sexpIso = match
+    $ With (. defconst)
+    $ With (. defun)
+    $ End
+    where
+      defconst = list $ el (sym "define") >>> el symbol >>> el sexpIso
+      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
+      args = list $ el symbol >>> rest symbol
+  
 instance SexpIso Exp where
   sexpIso = match
     $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. sexpIso)
+    $ With (. if_)
+    $ With (. sexpIso)
     $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
     $ With (. lam)
     $ With (. symbol)
     $ End
     where
+      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
       lam = list
         ( el (sym "lambda")
           >>> el (sexpIso @(List Name))

app/Gyehoek/Sexp.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
 module Gyehoek.Sexp
   ( let_
   , sexp
@@ -8,12 +9,14 @@ module Gyehoek.Sexp
   , nonEmptyGrammar
   , encode
   , decode
+  , parseSexps
   )
 where
 
 import Data.Text (Text)
 import Language.SexpGrammar as Sexp hiding (List, encode, decode, iso)
 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
@@ -24,6 +27,12 @@ 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
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -37,6 +46,10 @@ encode = (_Right %~ decodeUtf8 . view strict) . Sexp.encode
 decode :: SexpIso a => Text -> Either String a
 decode = Sexp.decode . view lazy . encodeUtf8
 
+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) -> xs :- x :- t)

app/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedLabels #-}
 module Main
   (main)
   where
@@ -6,20 +7,48 @@ import qualified Gyehoek.ANF.Syntax as ANF
 import Gyehoek.QBE (render)
 import Gyehoek.Options
 import qualified Data.Text.IO as TIO
-import Prelude hiding ((.),id)
+import Data.Text (Text)
+import Prelude hiding (readFile, (.),id)
 import Control.Category
 import Options.Applicative
+import Control.Lens
+import Data.Generics.Labels
+import System.OsPath (OsPath)
+import System.FilePath ((-<.>))
+import Effectful.FileSystem
+import Effectful
+import Effectful.FileSystem.IO
+import Gyehoek.GenSym (runGenSym)
+import qualified Gyehoek.Sexp as Sexp
+import Data.Text.Lens
+import Data.List (List)
+import qualified Gyehoek.Scheme.Syntax as Scm
+import Effectful.Exception
 
 
 main :: IO ()
-main = driver =<< execParser opts
+main = do
-  where
+  opts <- info (helper <*> parser) (fullDesc)
-    opts = info (helper <*> parser)
+  runEff . runFileSystem . driver $ opts
-      ( fullDesc
-      )
 
 
 
-driver :: Options -> IO ()
+hPutStr :: IOE :> es => Handle -> Text -> Eff es ()
-driver opts = do
+hPutStr h = liftIO . TIO.hPutStr h
-  print opts
+
+readFile :: IOE :> es => FilePath -> Eff es Text
+readFile = liftIO . TIO.readFile
+
+readScm :: FileSystem :> es => FilePath -> Eff es (List Scm.Exp)
+readScm f = (Sexp.parseSexps f <$> readFile f) >>= either error pure
+
+driver :: FileSystem :> es => Options -> Eff es ()
+driver = runGenSym . traverseOf_ (#sourceFiles . folded) \f ->
+  withFile f ReadMode \h_scm ->
+    (Sexp.encode <$> ANF.toANF _) >>= \case
+      Left e -> hPutStr stderr (view packed e)
+      Right s ->
+        withFile (f -<.> "anf") WriteMode \h_anf -> do
+          hPutStr h_anf ";;; -*- mode:scheme -*-\n\n"
+          hPutStr h_anf s
+

gyehoek.cabal

@@ -49,6 +49,7 @@ executable gyehoek
     , effectful
     , effectful-core
     , effectful-plugin
+    , filepath
     , generic-lens
     , invertible-grammar
     , lens
@@ -56,6 +57,7 @@ executable gyehoek
     , mtl
     , optparse-applicative
     , prettyprinter
+    , process
     , qbe
     , recursion-schemes
     , sexp-grammar