fuckeverythingggg

.gitignore

@@ -7,4 +7,5 @@ dist-newstyle
 .ghc.environment.*
 *.tix
 .direnv
-result
+result
+play/

README.md

@@ -1,3 +1,3 @@
 # gyehoek-hs (계획)
 
-a (wip) toy compiler for a Scheme-like language. currently targetting [QBE](https://c9x.me/compile/) (an LLVM-like intermediate representation). uses ANF and some other GHC-esque compilation techniques.
+a (wip) toy compiler for a Scheme-like language. currently targetting [QBE](https://c9x.me/compile/). nabbing from GHC and GNU Guile.

app/Gyehoek/ANF.hs

@@ -1,408 +0,0 @@
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# OPTIONS_GHC -Wno-orphans -Wno-unused-matches -Wno-missing-signatures #-}
-{- HLINT ignore "Avoid lambda using `infix`" -}
-module Gyehoek.ANF
-  (toANF, lower)
-  where
-
-import Data.Text (Text)
-import Effectful
-import Gyehoek.QBE qualified as QBE
-import Data.List (List)
-import Data.Text.IO qualified as TIO
-import Control.Lens
-import Data.Generics.Labels
-import Data.Vector.Strict (Vector)
-import Data.Function (fix)
-import Effectful.Writer.Static.Local
-import Gyehoek.Syntax qualified as Lam
-import Gyehoek.Syntax (Name, Prim(..), Lit(..))
-import Gyehoek.GenSym
-import Control.Monad.Cont
-import Data.Foldable
-import Data.List.NonEmpty (NonEmpty((:|)), toList)
-import Data.List.NonEmpty qualified as NE
-import Gyehoek.QBE (FuncDef(FuncDef))
-import Data.Foldable1
-import qualified Data.Text as T
-import Data.String (fromString)
-import Language.SexpGrammar as Sexp hiding (List, iso, encode, decode)
-import Language.SexpGrammar.Generic
-import GHC.Generics (Generic)
-import Gyehoek.Sexp
-import Control.Category
-import Prelude hiding ((.), id)
-import Data.InvertibleGrammar.Base qualified as IG
-import Data.InvertibleGrammar.Base ((:-)((:-)))
-import qualified Gyehoek.Sexp
-import Control.Lens.Unsound
-import qualified Data.Bits
-
-
-data Val
-  = ValLit Lit
-  | ValVar Name
-  deriving (Show, Generic)
-
-data Exp
-  = ExpLetApply Name Val (List Val) Exp
-  | ExpLetPrim Name (Prim Val) Exp
-  | ExpBegin (List Exp)
-  | ExpVal Val
-  deriving (Show, Generic)
-
-
-
-expandBindings
-  -- | Match constructor. (an affine fold would be preferable to a
-  --   prism here)
-  :: Prism' e (lhs, rhs, e)
-  -> e
-  -> (List (lhs, rhs), e)
-expandBindings p = go [] where
-  go acc e =
-    case e ^? p of
-      Just (l,r,e') -> go ((l,r):acc) e'
-      Nothing -> (acc, e)
-
-collapseBindings
-  :: Foldable f => AReview e (lhs, rhs, e) -> f (lhs, rhs)
-  -> e -> e
-collapseBindings p bs e = foldr (\(l,r) e' -> p # (l,r,e')) e bs
-
--- | Technically unlawful.
-bindingTelescope
-  :: Prism' e (lhs, rhs, e)
-  -> Iso' e (List (lhs, rhs), e)
-bindingTelescope p = iso
-  (expandBindings p)
-  (uncurry $ collapseBindings p)
-
-foldLet
-  :: Prism' Exp (lhs, rhs, Exp)
-  -> Grammar
-       Position
-       (Exp :- NonEmpty (lhs, rhs) :- t)
-       (Exp :- rhs :- lhs :- t)
-foldLet p =
-  IG.Iso
-    (\(e :- ((l1,r1):|bs) :- t) ->
-       collapseBindings p bs e :- r1 :- l1 :- t)
-    (\(e :- r :- l :- t) ->
-       let (bs,e') = expandBindings p e
-       in e' :- ((l,r) :| bs) :- t)
-
-instance SexpIso Val where
-  sexpIso = match
-    $ With (. sexpIso)
-    $ With (. symbol)
-    $ End
-
-nonEmptyIso :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b)
-nonEmptyIso = iso (\(x:|xs) -> (x,xs)) (uncurry (:|))
-
--- nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
--- nonEmptyGrammar = IG.Iso
---   (\((x:|xs) :- t) -> xs :- x :- t)
---   (\(xs :- x :- t) -> (x:|xs) :- t)
-
-instance SexpIso Exp where
-  sexpIso = match
-    $ With (. letapp)
-    $ With (. letprim)
-    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
-    $ With (. sexpIso)
-    $ End
-    where
-      letprim
-        :: Grammar Position (Sexp :- t) (Exp :- (Prim Val :- (Text :- t)))
-      letprim =
-        Gyehoek.Sexp.let_ symbol (sexpIso @(Prim Val)) (sexpIso @Exp)
-        >>> foldLet #ExpLetPrim
-      letapp :: Grammar
-        Position (Sexp :- t) (Exp :- List Val :- Val :- Text :- t)
-      letapp =
-        Gyehoek.Sexp.let_ symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp)
-         >>> foldLet (#ExpLetApply
-                      . iso (\(rhs,f,xs,e) -> (rhs, f:|xs, e))
-                            (\(rhs,f:|xs,e) -> (rhs,f,xs,e)))
-         >>> onTail nonEmptyGrammar
-
-
-
--- 뻘짓이어라
-telescope :: Traversable t => t ((a -> r) -> r) -> (t a -> r) -> r
-telescope = runCont . traverse cont
-
-toANF'
-  :: forall es. GenSym :> es
-  => Lam.Exp
-  -> (Val -> Eff es Exp)
-  -> Eff es Exp
-
-toANF' (Lam.ExpLit v) k = k . ValLit $ v
-
-toANF' (Lam.ExpPrim p) k =
-  telescope (toANF' <$> p) \p' -> do
-    r <- gensym
-    ExpLetPrim r p' <$> k (ValVar r)
-
-toANF' (Lam.ExpApply f xs) k =
-  telescope (toANF' <$> (f:|xs)) \(f':|xs') -> do
-    r <- gensym
-    ExpLetApply r f' xs' <$> k (ValVar r)
-
-toANF' (Lam.ExpBegin xs) k = ExpBegin <$> traverse anf xs
-  where
-    anf x = toANF' x (pure . ExpVal)
-
-toANF' e k = _
-
-toANF e = toANF' e (pure . ExpVal)
-
-
-
-expr =
-  Lam.ExpPrim
-    (PrimAdd
-     (Lam.ExpPrim
-      (PrimMul
-       (Lam.ExpLit (LitInt 2))
-       (Lam.ExpLit (LitInt 3))))
-    (Lam.ExpLit (LitInt 4)))
-
-expr2 =
-  Lam.ExpBegin
-    [ Lam.ExpPrim
-      (PrimWrite
-       (Lam.ExpPrim
-         (PrimCons
-          (Lam.ExpLit (LitInt 2))
-          (Lam.ExpLit (LitInt 3)))))
-    , Lam.ExpPrim (PrimWrite (Lam.ExpLit (LitInt 4)))
-    ]
-
-
-
-instance Semigroup QBE.Program where
-  QBE.Program ts ds fs <> QBE.Program ts' ds' fs' =
-    QBE.Program (ts <> ts') (ds <> ds') (fs <> fs')
-
-instance Monoid QBE.Program where
-  mempty :: QBE.Program
-  mempty = QBE.Program mempty mempty mempty
-
-funcdef
-  :: QBE.Ident QBE.Global
-  -> List QBE.Param -> NonEmpty QBE.Block -> FuncDef
-funcdef name ps =
-  QBE.FuncDef
-  mempty
-  (Just (QBE.AbiBaseTy QBE.Long))
-  name Nothing ps QBE.NoVariadic
-
-prims :: QBE.Program
-prims = QBE.Program primtys mempty primfns where
-  primtys =
-    [ QBE.TypeDef "scm" Nothing
-      [ (QBE.SubExtTy (QBE.BaseTy QBE.Long), Just 2) ]
-    ]
-  primfns = [ -- write
-            -- , mkArith "plus" QBE.Add
-            -- , mkArith "star" QBE.Mul
-            -- , mkArith "_" QBE.Sub
-            -- , mkArith "slash" (QBE.Div QBE.Signed)
-            ]
-  mkArith name bop =
-    funcdef name
-    [ QBE.Param (QBE.AbiBaseTy QBE.Long) "x"
-    , QBE.Param (QBE.AbiBaseTy QBE.Long) "y"
-    ]
-    [ QBE.Block "start" []
-      [ QBE.BinaryOp ("r" QBE.:= QBE.Long) bop
-        (QBE.ValTemporary "x") (QBE.ValTemporary "y")
-      ]
-      (QBE.Ret (Just (QBE.ValTemporary "r")))
-    ]
-
-data BlockBuilder
-  = Emit (Vector QBE.Inst) !BlockBuilder
-  | Exit QBE.Jump
-  deriving (Show)
-
-instance Semigroup BlockBuilder where
-  Emit a as <> bs = Emit a (as <> bs)
-  Exit _ <> bs = bs
-
-instance Each BlockBuilder BlockBuilder QBE.Inst QBE.Inst where
-  each k (Emit is bb) = Emit <$> traverse k is <*> each k bb
-  each k (Exit j) = pure (Exit j)
-
-evalBlockBuilder :: BlockBuilder -> (Vector QBE.Inst, QBE.Jump)
-evalBlockBuilder (Emit is bb) = evalBlockBuilder bb & _1 <>:~ is
-evalBlockBuilder (Exit j)     = ([],j)
-
-buildBlock :: QBE.Ident QBE.Label -> BlockBuilder -> QBE.Block
-buildBlock n bb = QBE.Block n [] (is ^.. each) j
-  where (is,j) = evalBlockBuilder bb
-
-lowerName :: Name -> QBE.Ident t
-lowerName = fromString . T.unpack
-
-lowerInt = QBE.ValConst . QBE.CInt
-  . (Data.Bits..|. 2)
-  . (Data.Bits..<<. 2) . fromIntegral
-
-lowerVal
-  :: forall es. (GenSym :> es)
-  => Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-
-lowerVal (ValLit (LitInt n)) k = k . lowerInt $ n
-lowerVal (ValLit _) k = error "todo"
-lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
-
-binaryPrim :: Prism' (Prim a) (QBE.BinaryOp, a, a)
-binaryPrim = prism' up down where
-  up (bop,a,b) = case bop of
-    QBE.Add -> _
-    QBE.Mul -> _
-    _ -> _
-  down = \case
-    PrimAdd a b -> Just (QBE.Add,a,b)
-    PrimMul a b -> Just (QBE.Mul,a,b)
-    _ -> Nothing
-
-lowerArithmetic :: QBE.Assignment -> Prim QBE.Val -> QBE.Inst
-lowerArithmetic r p = QBE.BinaryOp r bop x y
-  where
-    (bop,x,y) = case p of
-      PrimAdd a b -> (QBE.Add,a,b)
-      PrimMul a b -> (QBE.Mul,a,b)
-      _ -> _
-
-sizeofScm = 16
-
-lowerCons
-  :: (GenSym :> es)
-  => Name -> QBE.Val -> QBE.Val -> Exp
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-lowerCons r car cdr e k = do
-  r1 <- gensym
-  Emit (alloc <> initialise r1) <$> lower' e k
-  where
-    alloc = [ QBE.Call
-              (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
-              (QBE.ValGlobal "GC_malloc")
-              Nothing
-              [ QBE.Arg
-                (QBE.AbiBaseTy QBE.Long)
-                (QBE.ValConst (QBE.CInt sizeofScm)) ]
-              []
-            ]
-    initialise r1 =
-      [ QBE.BinaryOp (r1 QBE.:= QBE.Long) QBE.Add
-        (QBE.ValTemporary (lowerName r)) (QBE.ValConst (QBE.CInt 8))
-      , QBE.Store (QBE.BaseTy QBE.Long) car (QBE.ValTemporary (lowerName r))
-      , QBE.Store (QBE.BaseTy QBE.Long) cdr (QBE.ValTemporary r1)
-      ]
-
-smallIntHelper
-  :: GenSym :> es
-  => _
-  -> QBE.Val -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-smallIntHelper bop v k = do
-  r <- gensym
-  Emit [ QBE.BinaryOp (r QBE.:= QBE.Long)
-         bop v (QBE.ValConst (QBE.CInt 2)) ]
-    <$> k (QBE.ValTemporary r)
-
-makeSmallInt
-  :: forall es. (GenSym :> es)
-  => QBE.Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-makeSmallInt n k =
-  smallIntHelper QBE.Shl n \n' ->
-    smallIntHelper QBE.And n' k
-
-getSmallInt
-  :: forall es. (GenSym :> es)
-  => QBE.Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-getSmallInt = smallIntHelper QBE.Shr
-
-lowerWrite 
-  :: forall es. (GenSym :> es)
-  => Name -> QBE.Val -> Exp
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-lowerWrite r x e k =
-  Emit [ QBE.Call (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
-         (QBE.ValGlobal "scm_write") Nothing
-         [QBE.Arg (QBE.AbiBaseTy QBE.Long) x]
-         []
-       ]
-    <$> k (QBE.ValTemporary (lowerName r))
-
-lowerPrim 
-  :: forall es. (GenSym :> es)
-  => Name -> Prim Val -> Exp
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-lowerPrim r p e k =
-  telescope (lowerVal <$> p) \case
-    (preview binaryPrim -> Just (bop,a,b)) -> do
-      r1 <- gensym
-      Emit [ QBE.BinaryOp (r1 QBE.:= QBE.Long) bop a b
-           , QBE.BinaryOp (lowerName r QBE.:= QBE.Long) QBE.And
-             (QBE.ValTemporary r1) (QBE.ValConst (QBE.CInt 0b10))
-           ]
-        <$> lower' e k
-    PrimCons x y -> lowerCons r x y e k
-    PrimWrite x -> lowerWrite r x e k
-
-lower'
-  :: forall es. (GenSym :> es)
-  => Exp
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-
-lower' (ExpVal v) k = lowerVal v k
-
-lower' (ExpLetPrim r p e) k = lowerPrim r p e k
-
-lower' (ExpLetApply r f xs e) k =
-  telescope (lowerVal @es <$> (f:|xs)) \(f':|xs') ->
-    Emit [ QBE.Call
-            (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
-            f'
-            Nothing
-            (QBE.Arg (QBE.AbiBaseTy QBE.Long) <$> xs')
-            []
-          ]
-      <$> lower' e k
-
-lower' (ExpBegin (x:xs)) k = fold1 <$> traverse low (x:|xs)
-  where low e = lower' @es e (pure . Exit . QBE.Ret . Just)
-
-lower' _ k = _
-
-lower :: GenSym :> es => QBE.Ident QBE.Label -> Exp -> Eff es QBE.Block
-lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
-
-wrapProgram :: Foldable1 t => t QBE.Block -> QBE.Program
-wrapProgram bs = prims <> QBE.Program [] [] [main] where
-  main = QBE.FuncDef [QBE.Export]
-    (Just (QBE.AbiBaseTy QBE.Word))
-    "main" Nothing [] QBE.NoVariadic (toNonEmpty bs)

app/Gyehoek/CPS/Convert.hs

@@ -0,0 +1,49 @@
+{-# 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 = _

app/Gyehoek/CPS/Lower.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultilineStrings #-}
+{-# 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)
+
+
+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 -> Vector Text
+
+lowerVal g (ValLit l) =
+  case l of
+    LitInt n -> [ "i32.const " <> tshow n ]
+    _ -> _
+
+lowerVal g (ValVar x) = [ "local.get " <> tshow i ]
+  where
+    i = V.elemIndex x g.vars ^?! _Just
+
+lower' :: Env -> Exp -> Vector Text
+
+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 op g x y r e =
+  lowerVal g x
+  <> lowerVal g y
+  <> [ op, "local.set " <> tshow n ]
+  <> lower' g' e
+  where
+    g' = g & #vars <>~ [r]
+    n = length (g ^. #vars)
+
+
+
+makeFunc :: Vector Text -> Text
+makeFunc = (preamble<>) . (<>postamble) . T.unlines . toList . fmap indent
+  where
+    indent = ("    "<>)
+    preamble  = "(module\n\
+                \  (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/CPS/Syntax.hs

@@ -0,0 +1,97 @@
+{-# 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

app/Gyehoek/GenSym.hs

@@ -6,29 +6,32 @@ import Numeric.Natural
 import Effectful.State.Dynamic
 import Effectful.Dispatch.Dynamic
 import Effectful
-import Language.QBE as QBE
 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
 
-runGenSym :: Eff (GenSym : es) a -> Eff es a
+gensym' :: forall a es. (Gen a, GenSym :> es) => Text -> Eff es a
-runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \_ GenSym ->
+gensym' = send . GenSym'
-  state \n -> (gen n, succ n)
-  -- state \n -> (Ident . fromString $ '.' : show n, succ n)
 
-instance Gen (QBE.Ident s) where
+runGenSym :: Eff (GenSym : es) a -> Eff es a
-  gen = Ident . fromString . ('.':) . show
+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

app/Gyehoek/Options.hs

@@ -0,0 +1,51 @@
+{-# 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")

app/Gyehoek/QBE.hs

@@ -1,61 +0,0 @@
-{-# LANGUAGE RequiredTypeArguments #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
-module Gyehoek.QBE
-  ( module QBE
-  , render
-  , fn
-  , writeTo
-  )
-  where
-
-import Gyehoek.QBE.Parse
-import Language.QBE as QBE
-import Data.String (IsString(fromString))
-import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
-import Data.Text (Text)
-import Data.Data
-import Prettyprinter.Render.Text (renderStrict)
-import Text.Megaparsec
-import Text.Megaparsec.Char
-import Language.Haskell.TH qualified as TH
-import Language.Haskell.TH.Quote
-import Data.Kind (Type)
-import qualified Data.Text.IO as TIO
-
-
-writeTo :: FilePath -> Text -> IO ()
-writeTo = TIO.writeFile
-
-render :: Pretty a => a -> Text
-render = renderStrict . layoutPretty defaultLayoutOptions . pretty
-
-
-
-parseQuoteExp
-  :: (TH.Quote m, MonadFail m, Data a) => P a -> String -> m TH.Exp
-parseQuoteExp p s =
-  case parse (space *> p <* space <* eof) "qq" (fromString s) of
-    Left es -> fail . foldMap f . bundleErrors $ es
-      where f e = parseErrorPretty e ++ "\n\n"
-    Right x -> dataToExpQ (\_ -> Nothing) x
-
--- quoteExp :: TH.Quote m => forall (t :: Type) -> (Parser t) => String -> m TH.Exp
--- quoteExp t s = case parse (parser @t) "qq" (fromString s) of
---   Left es -> _
---   Right x -> dataToExpQ (\_ -> Nothing) x
-
-makeQQ :: forall (t :: Type) -> Parser t => QuasiQuoter
-makeQQ t = QuasiQuoter
-  { quoteExp = parseQuoteExp (parser @t)
-  , quotePat = _
-  , quoteType = undefined
-  , quoteDec = undefined
-  }
-
-fn :: QuasiQuoter
-fn = makeQQ (type FuncDef)

app/Gyehoek/QBE/Parse.hs

@@ -1,194 +0,0 @@
-{-# LANGUAGE RequiredTypeArguments #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-module Gyehoek.QBE.Parse where
-
-import Language.QBE as QBE
-import Effectful.State.Dynamic
-import Effectful.Dispatch.Dynamic
-import Effectful
-import Numeric.Natural
-import Data.String (IsString(fromString))
-import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
-import Data.Text (Text)
-import Data.Data
-import Prettyprinter.Render.Text (renderStrict)
-import Text.Megaparsec
-import Text.Megaparsec.Char
-import Text.Megaparsec.Char.Lexer qualified as L
-import Data.Void (Void)
-import Data.Char (isAlpha, isAlphaNum)
-import Control.Lens.Wrapped
-import Data.Functor.Contravariant (Predicate(Predicate))
-import qualified Data.Text as T
-import Data.Functor
-import Data.List (List)
-import Data.Foldable (fold)
-import Data.Maybe (isJust, fromMaybe)
-import Control.Monad.Fix (MonadFix(mfix))
-import Data.List.NonEmpty (fromList)
-import Language.Haskell.TH qualified as TH
-import Language.Haskell.TH.Quote
-import Data.Proxy
-import Data.Kind (Type)
-
-
-type P = Parsec Void Text
-
-sc :: P ()
-sc = L.space hspace1 (L.skipLineComment "#") empty
-
-lexeme :: P a -> P a
-lexeme = L.lexeme sc
-
-symbol :: Text -> P Text
-symbol = L.symbol sc
-
-infixr 8 .:
-(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
-(.:) f g x y = f (g x y)
-
-rawIdent :: P QBE.RawIdent
-rawIdent = (fromString .: (:) <$> lead <*> trail) <?> "ident"
-  where
-    lead = satisfy \x -> isAlpha x || (x=='.') || (x=='_')
-    trail = fmap T.unpack . takeWhileP Nothing $ \x ->
-      isAlphaNum x || (x=='.') || (x=='_')
-
-class ParseIdent (s :: Sigil) where
-  ident :: P (QBE.Ident s)
-
-rawIdentWithSigil :: Char -> P (Ident t)
-rawIdentWithSigil c = Ident <$> lexeme (char c *> rawIdent)
-
-instance ParseIdent AggregateTy where ident = rawIdentWithSigil ':'
-instance ParseIdent Global      where ident = rawIdentWithSigil '$'
-instance ParseIdent Temporary   where ident = rawIdentWithSigil '%'
-instance ParseIdent QBE.Label   where ident = rawIdentWithSigil '@'
-
-const :: P QBE.Const
-const = cint <|> csingle <|> cdouble <|> cglobal <?> "const"
-  where
-    cint = CInt <$> lexeme (L.signed empty L.decimal) <?> "integer"
-    csingle = empty <?> "single-precision float"
-    cdouble = empty <?> "double-precision float"
-    cglobal = CGlobal <$> ident <?> "global symbol"
-
-val :: P QBE.Val
-val = vconst <|> vtemp <?> "val"
-  where
-    vconst = ValConst <$> Gyehoek.QBE.Parse.const
-    vtemp = ValTemporary <$> ident <?> "temporary symbol"
-
-assignment :: P QBE.Assignment
-assignment =
-  Assignment <$> ident <*> (char '=' *> basety)
-
-basety :: P QBE.BaseTy
-basety = lexeme $ char 'w' $> Word
-              <|> char 'l' $> Long
-              <|> char 's' $> Single
-              <|> char 'd' $> Double
-
-abity :: P AbiTy
-abity = AbiBaseTy <$> basety
-    <|> AbiAggregateTy <$> ident
-
-binaryOp :: P QBE.BinaryOp
-binaryOp = lexeme $ "add" $> Add
-                <|> "sub" $> Sub
-                <|> "mul" $> Mul
-                <|> "div" $> Div Signed
-
-comma :: P a -> P a
-comma p = symbol "," *> p
-
-inst :: P QBE.Inst
-inst = try binaryOpInst <|> negInst <?> "inst"
-  where
-    binaryOpInst =
-      BinaryOp
-        <$> assignment
-        <*> binaryOp
-        <*> val <*> comma val
-    negInst = Neg <$> assignment <*> (symbol "neg" *> val)
-
-jump :: P QBE.Jump
-jump = jmp <|> jnz <|> ret <|> hlt <?> "jump"
-  where
-    jmp = symbol "jmp" *> (Jmp <$> ident)
-    jnz = symbol "jnz" *> (Jnz <$> val <*> ident <*> comma ident)
-    ret = symbol "ret" *> (Ret <$> optional val)
-    hlt = empty
-
-nl :: P ()
-nl = void (some (newline *> sc)) <?> "newline"
-
-phi :: P QBE.Phi
-phi = empty
-
-block :: P QBE.Block
-block = Block
-  <$> (ident <* nl)
-  <*> sepBy phi nl
-  <*> sepBy inst nl
-  <*> jump
-
-sepByTry :: MonadParsec e s m => m a -> m sep -> m (List a)
-sepByTry p sep = do
-  x <- p
-  xs <- many (try $ sep *> p)
-  pure (x:xs)
-
-paramList :: P (Maybe (Ident Temporary), List Param, Variadic)
-paramList = label "parameter list" $ between (symbol "(") (symbol ")") do
-  e <- optional env
-  ps <- optional . try $ do
-    commaIf (isJust e)
-    sepByTry reg (symbol ",")
-  v <- optional do
-    commaIf (isJust e || isJust ps)
-    variadic
-  pure (e, fromMaybe [] ps, fromMaybe NoVariadic v)
-  where
-    commaIf True = void $ symbol ","
-    commaIf False = pure ()
-    env = symbol "env" *> ident @Temporary <?> "environment parameter"
-    reg = Param <$> abity <*> ident <?> "regular parameter"
-    variadic = symbol "..." $> Variadic <?> "variadic parameter"
-
-funcdef :: P QBE.FuncDef
-funcdef = do
-  linkages <- many linkage
-  symbol "function"
-  returnTy <- optional abity
-  name <- ident @Global
-  (env,params,variadic) <- paramList
-  code <- fmap fromList . between (symbol "{" *> nl) (symbol "}") $
-    sepEndBy1 block nl
-  pure $ FuncDef linkages returnTy name env params variadic code
-
-linkage :: P Linkage
-linkage = symbol "export" $> Export
-
--- stripped :: P a -> P a
--- stripped p = optional nl *>
-
-
-
-class Data a => Parser a where
-  parser :: P a
-
-instance Parser FuncDef where parser = funcdef
-
-class ParseSeparator a where
-  parseSeparator :: Proxy a -> P ()
-
-instance (Parser a, ParseSeparator a) => Parser (List a) where
-  parser = sepBy parser (parseSeparator @a Proxy)
-
-instance ParseSeparator FuncDef where parseSeparator _ = nl
-instance ParseSeparator Block where parseSeparator _ = nl

app/Gyehoek/Scheme/Syntax.hs

@@ -0,0 +1,166 @@
+{-# 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 )

app/Gyehoek/Scratch.hs

@@ -1 +0,0 @@
-module Gyehoek.Scratch where

app/Gyehoek/Sexp.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
 module Gyehoek.Sexp
   ( let_
   , sexp
@@ -8,12 +9,23 @@ module Gyehoek.Sexp
   , nonEmptyGrammar
   , encode
   , decode
+  , parseSexps
+  , prefixSugar
+  , todo
+  , isoIso
+  , encodeWith
+  , decodeWith
+  , kappa
+  , lambda
+  , kappaKeyword
+  , lambdaKeyword
   )
 where
 
 import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (List, encode, decode, iso)
+import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, 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 +36,13 @@ 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
@@ -32,15 +51,25 @@ sexp = iso
   (either error id . decode)
 
 encode :: SexpIso a => a -> Either String Text
-encode = (_Right %~ decodeUtf8 . view strict) . Sexp.encode
+encode = encodeWith sexpIso
 
 decode :: SexpIso a => Text -> Either String a
-decode = Sexp.decode . view lazy . encodeUtf8
+decode = decodeWith sexpIso
+
+encodeWith :: SexpGrammar a -> a -> Either String Text
+encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g
+
+decodeWith :: SexpGrammar a -> Text -> Either String a
+decodeWith g = Sexp.decodeWith g "FILE" . 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)
+  (\((x:|xs) :- t) -> reverse xs :- x :- t)
-  (\(xs :- x :- t) -> (x:|xs) :- t)
+  (\(xs :- x :- t) -> (x :| reverse xs) :- t)
 
 nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
 nonempty a =
@@ -48,11 +77,12 @@ nonempty a =
     IG.flipped nonEmptyGrammar
 
 let_
-  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
+  :: 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_ name rhs e = list (el (sym "let") >>> el bindings >>> el e)
+let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
   where
     -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
     bindings = nonempty binding
@@ -67,11 +97,47 @@ 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 (sym "lambda")
+  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" ]

app/Gyehoek/Syntax.hs

@@ -1,95 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-module Gyehoek.Syntax where
-
-import Data.Text (Text)
-import Data.List (List)
-import Language.SexpGrammar as Sexp hiding (List)
-import Language.SexpGrammar.Generic
-import GHC.Generics
-import Prelude hiding ((.), id)
-import Control.Category
-import Data.List.NonEmpty (NonEmpty ((:|)))
-import Gyehoek.Sexp qualified
-import Control.Lens (Each)
-
-
-type Name = Text
-
-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
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-
-instance Each (Prim e) (Prim e') e e'
-
-data Lit
-  = LitInt Int
-  | LitNil
-  | LitBool Bool
-  deriving (Show, Generic)
-
-data Exp
-  = ExpLet (NonEmpty (Name, Exp)) Exp
-  | ExpPrim (Prim Exp)
-  | ExpBegin (List Exp)
-  | ExpLit Lit
-  | ExpApply Exp (List Exp)
-  | ExpLambda (List Name) Exp
-  | ExpVar Name
-  deriving (Show, Generic)
-
-
-
-instance SexpIso a => SexpIso (Prim a) where
-  sexpIso = 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")
-    $ End
-    where
-      primname = ("prim:" <>)
-      unop s = list $ el (sym (primname s)) >>> el sexpIso
-      binop s = list $ el (sym (primname s)) >>> el sexpIso >>> el sexpIso
-
-instance SexpIso Lit where
-  sexpIso = match
-    $ With (. sexpIso)
-    $ With (. sym "nil")
-    $ With (. sexpIso)
-    $ End
-
-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 (\app -> app . list (el sexpIso >>> rest sexpIso))
-    $ With (. lam)
-    $ With (. symbol)
-    $ End
-    where
-      lam = list
-        ( el (sym "lambda")
-          >>> el (sexpIso @(List Name))
-          >>> el sexpIso )

app/Gyehoek/Wasm.hs

@@ -0,0 +1,28 @@
+{- HLINT ignore "Use newtype instead of data" -}
+module Gyehoek.Wasm
+  ()
+  where
+
+import Data.List (List)
+import GHC.Generics (Generic)
+
+
+data Module = MkModule
+  { typeSection :: List Type
+  }
+  deriving (Show, Generic)
+
+data Type
+  deriving (Show, Generic)
+
+data Function = MkFunction
+  { params :: List Type
+  , result :: List Type
+  , locals :: List Type
+  , body :: Expr
+  }
+  deriving (Show, Generic)
+
+type Expr = List Instr
+
+type Instr = ByteString

app/Main.hs

@@ -1,17 +1,84 @@
-{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OrPatterns #-}
 module Main
   (main)
   where
 
-import qualified Gyehoek.ANF as ANF
+import Gyehoek.Options
-import Gyehoek.QBE (render)
 import qualified Data.Text.IO as TIO
-import Prelude hiding ((.),id)
+import Data.Text (Text)
-import Control.Category
+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)
 
 
 main :: IO ()
-main = TIO.putStrLn . render $ ANF.expr
+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

bdwgc.nix

@@ -1,18 +0,0 @@
-{ cmake
-, stdenv
-, fetchFromGitHub
-}:
-
-stdenv.mkDerivation (finalAttrs: {
-  pname = "bdwgc";
-  version = "8.2.12";
-  src = fetchFromGitHub {
-    owner = "bdwgc";
-    repo = "bdwgc";
-    tag = "v${finalAttrs.version}";
-    hash = "sha256-5yeAB5Y92YjOutwRXBJkMxoOLkmzmqIJs4PirKX89fE=";
-  };
-  nativeBuildInputs = [
-    cmake
-  ];
-})

cabal.project

@@ -3,5 +3,5 @@ packages: *.cabal
 source-repository-package
     type: git
     location: https://git.deertopia.net/msyds/qbe-hs.git
-    tag: ab7cc053a4d58fde841e910f251b8e48b54466ad
+    tag: 64be0096355a8fd23cc1a4910ed5c8e6075aeca9
-    --sha256: 0n2jqr6vymlyr0gwzbv3cljhqxnzcq1pzf7m92b16jalkymbcwgy
+    --sha256: 0x507fmpyzyvg3f27wss94d7fkrbv6r05jknlphgyi53pscazr9r

example/arith.scm

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

example/closure.scm

@@ -1,15 +0,0 @@
-(define (adder x)
-  (lambda (y)
-    (+ x y)))
-
-((adder 3) 4)
-
-
-
-(define (adder x)
-  (list (lambda (self y)
-          (+ (nth self 1) y))
-        x))
-
-(let ((closure (adder 3)))
-  ((nth closure 0) closure 4))

example/t.s

@@ -1,70 +0,0 @@
-.text
-zerop:
-	pushq %rbp
-	movq %rsp, %rbp
-	cmpl $0, %edi
-	jnz .Lbb2
-	movl $1, %eax
-	jmp .Lbb3
-.Lbb2:
-	movl $0, %eax
-.Lbb3:
-	leave
-	ret
-.type zerop, @function
-.size zerop, .-zerop
-/* end function zerop */
-
-.text
-factorial:
-	pushq %rbp
-	movq %rsp, %rbp
-	subq $8, %rsp
-	pushq %rbx
-	movq %rdi, %rbx
-	callq zerop
-	movq %rbx, %rdi
-	cmpl $0, %eax
-	jnz .Lbb6
-	movq %rdi, %rbx
-	subq $1, %rdi
-	callq factorial
-	movq %rbx, %rdi
-	imulq %rdi, %rax
-	jmp .Lbb7
-.Lbb6:
-	movl $1, %eax
-.Lbb7:
-	popq %rbx
-	leave
-	ret
-.type factorial, @function
-.size factorial, .-factorial
-/* end function factorial */
-
-.data
-.balign 8
-fstr:
-	.ascii "fac 3 = %d\n"
-	.byte 0
-/* end data */
-
-.text
-.globl main
-main:
-	pushq %rbp
-	movq %rsp, %rbp
-	movl $3, %edi
-	callq factorial
-	movq %rax, %rsi
-	leaq fstr(%rip), %rdi
-	movl $0, %eax
-	callq printf
-	movl $0, %eax
-	leave
-	ret
-.type main, @function
-.size main, .-main
-/* end function main */
-
-.section .note.GNU-stack,"",@progbits

example/t.scm

@@ -1,16 +0,0 @@
-(define (factorial n)
-  (if (zero? n)
-      1
-      (* n (factorial (- n 1)))))
-
-
-;;; ANF
-
-(define (factorial n)
-  (let ((r₁ (zero? n)))
-    (if r₁
-        1
-        (let ((r₂ (- n 1))
-              (r₃ (factorial r₂))
-              (r₄ (* n r₃)))
-          r₄))))

example/t.ssa

@@ -1,30 +0,0 @@
-function l $zerop (l %n) {
-@start
-	jnz %n, @b1, @b2
-@b1
-	ret 0
-@b2
-	ret 1
-}
-
-function l $factorial (l %n) {
-@start
-	%r1 =l call $zerop (l %n)
-	jnz %r1, @b1, @b2
-@b1
-	ret 1
-@b2
-	%r2 =l sub %n, 1
-	%r3 =l call $factorial (l %r2)
-	%r4 =l mul %n, %r3
-	ret %r4
-}
-
-data $fstr = { b "fac 3 = %d\n", b 0 }
-
-export function w $main () {
-@start
-	%r =l call $factorial (l 3)
-	call $printf (l $fstr, ..., l %r)
-	ret 0
-}

flake.lock

@@ -591,7 +591,8 @@
         "nixpkgs": [
           "haskellNix",
           "nixpkgs-unstable"
-        ]
+        ],
+        "sydpkgs": "sydpkgs"
       }
     },
     "stackage": {
@@ -609,6 +610,26 @@
         "repo": "stackage.nix",
         "type": "github"
       }
+    },
+    "sydpkgs": {
+      "inputs": {
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1778962331,
+        "narHash": "sha256-qMokSV7hsWYiDCkkBGyG0aD4Ds3JLzJzJ0Cp9f/spJU=",
+        "ref": "refs/heads/main",
+        "rev": "59d3a471cd960f9d1f6c645a4fe578a670848e9d",
+        "revCount": 41,
+        "type": "git",
+        "url": "https://git.deertopia.net/msyds/sydpkgs"
+      },
+      "original": {
+        "type": "git",
+        "url": "https://git.deertopia.net/msyds/sydpkgs"
+      }
     }
   },
   "root": "root",

flake.nix

@@ -3,9 +3,13 @@
     haskellNix.url = "github:input-output-hk/haskell.nix";
     # nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
     nixpkgs.follows = "haskellNix/nixpkgs-unstable";
+    sydpkgs = {
+      url = "git+https://git.deertopia.net/msyds/sydpkgs";
+      inputs.nixpkgs.follows = "nixpkgs";
+    };
   };
 
-  outputs = { self, nixpkgs, haskellNix, ... }@inputs:
+  outputs = { self, nixpkgs, sydpkgs, haskellNix, ... }@inputs:
     let
       supportedSystems = [
         "aarch64-darwin" "aarch64-linux"
@@ -15,26 +19,12 @@
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          bdwgc = final.callPackage ./bdwgc.nix {};
-        })
-        (final: prev: {
-          # haskellPackages = prev.haskellPackages.override {
-          #   qbe = final.haskell-nix.project' {
-          #     src = final.fetchFromGitea {
-          #       domain = "git.deertopia.net";
-          #       owner = "msyds";
-          #       repo = "qbe-hs";
-          #       rev = "master";
-          #       hash = "sha256-3Ni2xFOvw7Qjzq7BIXfnSQQ3U99OaEH0j6SdILMYizs=";
-          #     };
-          #     compiler-nix-name = "ghc912";
-          #   };
-          # };
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
             shell = {
               withHoogle = true;
+              inputsFrom = [];
               tools = {
                 cabal = {};
                 haskell-language-server = {};
@@ -43,9 +33,13 @@
                 gcc
                 qbe
                 haskellPackages.cabal-fmt
-                schemat
+                self.packages.${final.stdenv.hostPlatform.system}.shake
-                bdwgc
+                final.wabt
-                pkg-config
+                final.nodejs
+                final.wasmtime
+                final.wasm-tools
+                final.wac-cli
+                final.guile
               ];
             };
           };
@@ -76,8 +70,7 @@
       packages = each-system ({ pkgs, system, ... }:
         hf.packages.${system} // {
           default = hf.packages.${system}."gyehoek:exe:gyehoek";
-          runtime = pkgs.callPackage ./runtime {};
+          shake = pkgs.callPackage ./shake-wrapper.nix {};
-          inherit (pkgs) bdwgc;
         });
 
       devShells = each-system

gyehoek.cabal

@@ -13,48 +13,63 @@ build-type:    Simple
 -- extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
+common ghcstuffs-dev
+  ghc-options:
+    -Wno-unused-matches -Wno-missing-signatures -Wno-typed-holes
+
 common ghcstuffs
   ghc-options:
     -Wall -fdefer-type-errors -fno-show-valid-hole-fits
-    -fdefer-out-of-scope-variables -Wno-typed-holes
+    -fdefer-out-of-scope-variables -fplugin=Effectful.Plugin -threaded
-    -fplugin=Effectful.Plugin
 
-  other-extensions:
+  default-extensions:
     BlockArguments
+    DeriveGeneric
+    OverloadedRecordDot
+    OverloadedStrings
     PartialTypeSignatures
+    PatternSynonyms
 
 executable gyehoek
-  import:           ghcstuffs
+  import:           ghcstuffs, ghcstuffs-dev
   main-is:          Main.hs
 
   -- cabal-fmt: expand app -Main
   other-modules:
-    Gyehoek.ANF
+    Gyehoek.CPS.Convert
-    Gyehoek.Sexp
+    Gyehoek.CPS.Lower
+    Gyehoek.CPS.Syntax
     Gyehoek.GenSym
-    Gyehoek.QBE
+    Gyehoek.Options
-    Gyehoek.QBE.Parse
+    Gyehoek.Scheme.Syntax
-    Gyehoek.Scratch
+    Gyehoek.Sexp
-    Gyehoek.Syntax
+    Gyehoek.Wasm
 
-  -- other-extensions:
   build-depends:
-    , base               ^>=4.21.2.0
+    , base                  ^>=4.21.2.0
+    , binary
+    , containers
+    , cradle
     , effectful
     , effectful-core
     , effectful-plugin
+    , filepath
+    , generic-lens
+    , hashable
+    , invertible-grammar
     , lens
     , megaparsec
     , mtl
+    , optparse-applicative
     , prettyprinter
-    , qbe
+    , process
     , recursion-schemes
+    , sexp-grammar
     , template-haskell
     , text
+    , text-short
+    , unordered-containers
     , vector
-    , generic-lens
-    , sexp-grammar
-    , invertible-grammar
 
   hs-source-dirs:   app
   default-language: GHC2024

play/t.ssa

@@ -1,12 +0,0 @@
-type :scm = {l 2}
-export
-function w $main () {
-@start
-    %x0 =l call $GC_malloc (l 16)
-    %.3 =l add %x0, 8
-    storel 10, %x0
-    storel 14, %.3
-    %x1 =l call $scm_write (l %x0)
-    %x2 =l call $scm_write (l 18)
-    ret %x2
-}

repl

@@ -0,0 +1,2 @@
+#!/usr/bin/env sh
+cabal repl --repl-options "-interactive-print=Text.Pretty.Simple.pPrint" --build-depends pretty-simple

runtime/Makefile

@@ -1,8 +0,0 @@
-all: gyehoek.o
-
-gyehoek.o: gyehoek.c
-	$(CC) $(CFLAGS) -c gyehoek.c -o gyehoek.o
-
-.PHONY: install
-install:
-	install -Dm644 -t $(out)/lib gyehoek.o

runtime/default.nix

@@ -1,10 +0,0 @@
-{ stdenv
-, callPackage
-, bdwgc ? callPackage ../bdwgc.nix {}
-}:
-
-stdenv.mkDerivation {
-  pname = "gyehoek";
-  version = "1.0.0";
-  src = ./.;
-}

runtime/gyehoek.c

@@ -1,11 +0,0 @@
-#include <stdio.h>
-#include "gyehoek.h"
-
-SCM scm_write (SCM x) {
-  if (SCM_IMP (x)) {
-    printf ("#<immediate %ld>\n", SCM_UNPACK (x));
-  } else {
-    printf ("#<heap object %ld>\n", SCM_UNPACK(x));
-  }
-  return SCM_PACK(NULL);
-}

runtime/gyehoek.h

@@ -1,23 +0,0 @@
-#ifndef GYEHOEK_H
-#define GYEHOEK_H
-
-#include <stdint.h>
-
-
-
-typedef uintptr_t scm_t_bits;
-
-typedef union SCM { struct { scm_t_bits n; } n; } SCM;
-
-#define SCM_UNPACK(x) ((x).n.n)
-#define SCM_PACK(x) ((SCM) { { (scm_t_bits) (x) } })
-#define SCM_IMP(x) 		(6 & SCM_UNPACK (x))
-#define SCM_NIMP(x) 		(!SCM_IMP (x))
-#define SCM_HEAP_OBJECT_P(x)    (SCM_NIMP (x))
-
-
-
-SCM scm_write (SCM);
-
-
-#endif /* GYEHOEK_H */

shake-wrapper.nix

@@ -0,0 +1,14 @@
+{ runCommandLocal, makeWrapper, lib, haskellPackages }:
+
+let
+  our-ghc = haskellPackages.ghc.withPackages (ps: [
+    ps.shake
+  ]);
+in runCommandLocal
+  "shake-wrapper"
+  { nativeBuildInputs = [ makeWrapper ]; }
+  ''
+    mkdir -p $out/bin
+    makeWrapper ${lib.getExe haskellPackages.shake} $out/bin/shake \
+      --prefix PATH : ${lib.makeBinPath [our-ghc]}
+  ''