r7rs datum ast

.dir-locals.el

@@ -1,9 +1,11 @@
-((haskell-cabal-mode
+((haskell-mode
+  . ((eval
+      . (progn (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("cps" . scheme-mode))
+               (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("scm" . scheme-mode))))))
+ (haskell-cabal-mode
   . ((eval
       . (progn (defun apply-cabal-fmt-h ()
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
-               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)
+               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t))))))
-               (add-to-list 'haskell-font-lock-quasi-quote-modes
-                            '("cps" . scheme-mode))
-               (add-to-list 'haskell-font-lock-quasi-quote-modes
-                            '("scm" . scheme-mode)))))))

flake.nix

@@ -55,6 +55,11 @@
                 guile
                 rust-analyzer
                 wasmtime
+                # bashInteractive is necessary to work around an
+                # optparse-applicative issue
+                #
+                # https://github.com/pcapriotti/optparse-applicative/pull/408
+                bashInteractive
               ];
             };
           };

gyehoek.cabal

@@ -60,10 +60,15 @@ library
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
     Gyehoek.GenSym
+    Gyehoek.Language
     Gyehoek.Options
     Gyehoek.Prelude
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
+    Gyehoek.Sexp.Grammar
+    Gyehoek.Sexp.Print
+    Gyehoek.Sexp.Read
+    Gyehoek.Sexp.Syntax
     Gyehoek.Stack.Syntax
     Gyehoek.Stack.VM
     Gyehoek.Wasm
@@ -90,6 +95,7 @@ library
     , prettyprinter
     , process
     , recursion-schemes
+    , scientific
     , sexp-grammar
     , string-interpolate
     , template-haskell

src/Gyehoek/Driver.hs

@@ -77,8 +77,6 @@ inspectWasm wat = do
   let wasmtools_cfg
         = proc "wasm-tools" ["print", "-pf", "--print-operand-stack"
                             ,"--color", "always", "-"]
-          -- & setStdin (byteStringInput . view lazy . encodeUtf8 $ wat)
-          -- & setStdout byteStringOutput
           & setStdin createPipe
           & setStdout createPipe
           & setStderr inherit
@@ -128,12 +126,12 @@ driver opts = do
     (eval >>> fmap writeObj      
          >>> T.unwords          
          >>> hPutStrLn FS.stdout)
-  dumpOrRun False (rt_is #CPS)
+  when (rt_is #CPS) do
-    (pure closedCps)
+    closedCps
-    (const $ pure ())
+      & CPS.evalProgram
-    (CPS.evalProgram >>> fmap writeObj      
+      & fmap writeObj      
-         >>> T.unwords          
+      & T.unwords          
-         >>> hPutStrLn FS.stdout)
+      & hPutStrLn FS.stdout
   dumpOrRun opts.inspectWasm (rt_is #Wasm)
     (lowerProgram cps)
     inspectWasm

src/Gyehoek/Language.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Gyehoek.Language
+  ( Language(..)
+  ) where
+
+import Data.Kind (Type)
+import Gyehoek.Prelude
+import Language.SexpGrammar (Position, Grammar, (:-), Sexp)
+
+
+class Language l where
+  type Program l :: Type
+  languageName :: Text
+  programGrammar :: forall t. Grammar Position (List Sexp :- t) (Program l :- t)
+
+readProgramFile
+  :: forall l es. Language l
+  => FilePath -> Eff es (Program l)
+readProgramFile fp = _
+
+readProgramStringPos
+  :: forall l. Language l
+  => Position -> Text -> Either Text (Program l)
+readProgramStringPos pos s = _

src/Gyehoek/Options.hs

@@ -2,8 +2,9 @@
 {-# LANGUAGE RecordWildCards #-}
 module Gyehoek.Options
   ( Options(..)
-  , Runtime(..)
   , parser
+  , Runtime(..)
+  , Language(..)
   )
   where
 
@@ -13,7 +14,15 @@ import Gyehoek.Prelude hiding (argument)
 
 
 data Runtime = Stackify | Wasm | CPS
-  deriving (Show, Generic)
+  deriving (Show, Generic, Eq)
+
+data Language
+  = LanguageScheme
+  | LanguageCPS
+  | LanguageClosed
+  | LanguageStackified
+  | LanguageWasm
+  deriving (Show, Generic, Eq)
 
 data Options = MkOptions
   { dumpClosed :: Bool
@@ -24,9 +33,20 @@ data Options = MkOptions
   , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
+  , sourceLanguage :: Language
   }
   deriving (Show, Generic)
 
+languageValues = ["scheme","cps","closed","stackified","wasm"]
+languageReader = maybeReader \case
+  "scheme" -> Just LanguageScheme
+  "cps" -> Just LanguageCPS
+  "closed" -> Just LanguageClosed
+  "stackified" -> Just LanguageStackified
+  "wasm" -> Just LanguageWasm
+  _ -> Nothing
+
+runtimeValues = ["stackify","wasm","cps","none"]
 runtimeReader = maybeReader \case
   "stackify" -> Just (Just Stackify)
   "wasm" -> Just (Just Wasm)
@@ -45,14 +65,24 @@ parser = do
     [ long "runtime"
     , short 'R'
     , value (Just Stackify)
-    , completeWith ["stackify","wasm","cps","none"]
+    , completeWith runtimeValues
     , showDefaultWith $ const "stackify"
+    , metavar "RUNTIME"
+    ]
+  sourceLanguage <- option languageReader . fold $
+    [ long "source"
+    , short 'S'
+    , value LanguageScheme
+    , completeWith languageValues
+    , showDefaultWith $ const "scheme"
+    , metavar "LANGUAGE"
     ]
   output <- strOption . fold $
     [ long "output"
     , short 'o'
     , metavar "FILE"
     , value "-"
+    , action "file"
     ]
   sourceFile <- argument str . fold $
     [ metavar "FILE"

src/Gyehoek/Prelude.hs

@@ -14,6 +14,8 @@ module Gyehoek.Prelude
   , IsList(fromList)
   , HasCallStack
   , Hashable
+  , NonEmpty((:|))
+  , Natural
   ) where
 
 import Control.Lens
@@ -31,4 +33,6 @@ import Data.Generics.Labels ()
 import Data.String.Interpolate
 import GHC.Stack (HasCallStack)
 import Data.Hashable (Hashable)
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Numeric.Natural (Natural)
 

src/Gyehoek/Sexp.hs

@@ -26,6 +26,7 @@ module Gyehoek.Sexp
   , encodePrettyWith
   , encodePretty
   , SpliceSexp(..)
+  , Position(..)
   , parseSexpsWithPos
   , parseSexpWithPos
   , parseSexp

src/Gyehoek/Sexp/Grammar.hs

@@ -0,0 +1,4 @@
+module Gyehoek.Sexp.Grammar
+  (
+  ) where
+

src/Gyehoek/Sexp/Print.hs

@@ -0,0 +1,4 @@
+module Gyehoek.Sexp.Print
+  (
+  ) where
+

src/Gyehoek/Sexp/Read.hs

@@ -0,0 +1,4 @@
+module Gyehoek.Sexp.Read
+  (
+  ) where
+

src/Gyehoek/Sexp/Syntax.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE DeriveAnyClass #-}
+module Gyehoek.Sexp.Syntax
+  ( DatumF(..)
+  , Simple(..)
+  , CompoundF(..)
+  , Prefix(..)
+  , Delimiter(..)
+  , Label(..)
+  ) where
+
+import Language.Haskell.TH.Syntax (Lift)
+import Data.Scientific (Scientific)
+import Data.ByteString (ByteString)
+import Gyehoek.Prelude hiding (Simple)
+
+
+data DatumF a
+  = SimpleF Simple
+  | CompoundF (CompoundF a)
+  | LabeledF Label a
+  | LabelRefF Label
+  deriving stock (Show, Eq, Data, Generic, Lift)
+  deriving anyclass (NFData)
+
+data Simple
+  = SimpleBool Bool
+  | SimpleNumber Scientific
+  | SimpleChar
+  | SimpleString
+  | SimpleSymbol
+  | SimpleBytevector ByteString
+  deriving stock (Show, Eq, Data, Generic, Lift)
+  deriving anyclass (NFData)
+
+data CompoundF a
+  = ListF (List a)
+  | DotListF (NonEmpty a) a
+  | VectorF (List a)
+  | AbbrevF Prefix a
+  deriving stock (Show, Eq, Data, Generic, Lift)
+  deriving anyclass (NFData)
+
+data Prefix
+  = Quote | Backtick | Comma | CommaAt
+  deriving stock (Show, Eq, Data, Generic, Lift)
+  deriving anyclass (NFData)
+
+data Delimiter
+  = Paren
+  | Square
+  | Curly
+  deriving stock (Show, Eq, Data, Generic, Lift)
+  deriving anyclass (NFData)
+
+newtype Label = MkLabel Natural
+  deriving stock (Data, Generic, Lift)
+  deriving newtype (Eq, Ord, Show)
+  deriving anyclass (NFData)