app/Gyehoek/ANF.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE BlockArguments #-}
@@ -30,6 +31,13 @@ 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)
+import Language.SexpGrammar.Generic
+import GHC.Generics
+import Control.Category
+import Prelude hiding ((.), id)
+import Data.InvertibleGrammar.Base qualified as IG
+import Data.InvertibleGrammar.Base ((:-)((:-)))
 
 
 -- data Val
@@ -42,9 +50,41 @@ import Data.String (fromString)
 
 data Exp
   = ExpLetApply Name Val (List Val) Exp
-  | ExpProgn (List Exp)
+  | ExpBegin (List Exp)
   | ExpVal Val
-  deriving (Show)
+  deriving (Show, Generic)
+
+
+
+collapseBindings
+  :: Prism' Exp a -> Getter a Exp -> Exp -> (List a, Exp)
+collapseBindings p l e =
+  case e ^? p of
+    Just a -> collapseBindings p l (a ^. l) & _1 %~ (a:)
+    Nothing -> ([], e)
+
+instance SexpIso Exp where
+  sexpIso = match
+    $ With (. letapp)
+    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
+    $ With (. sexpIso)
+    $ End
+    where
+      letapp :: Grammar
+        Position (Sexp :- t) (Exp :- List Val :- Val :- Text :- t)
+      letapp = Lam.letIso symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp)
+         >>> IG.Iso bluh hulb
+      bluh (e :- ((r,f:|xs):bs) :- t) =
+        foldr (\(v,g:|ys) -> ExpLetApply v g ys) e bs :- xs :- f :- r :- t
+      bluh _ = error "empty let lol"
+      hulb :: (Exp :- ([Val] :- (Val :- (Text :- t))))
+           -> Exp :- ([(Name, NonEmpty Val)] :- t)
+      hulb (e :- xs :- f :- r :- t) = e' :- ((r,f:|xs):bs) :- t
+      -- hulb (e :- xs :- f :- r :- t) = ExpLetApply r f xs e' :- bs :- t
+        where
+          -- (bs,e') = ([],e)
+          (bs,e') = collapseBindings #ExpLetApply _4 e
+                  & _1 . each %~ \(x,g,ys,_) -> (x,g:|ys)
 
 
 

app/Gyehoek/Syntax.hs

@@ -44,7 +44,7 @@ letIso name rhs e = list (el (sym "let") >>> el bindings >>> el e)
   where
     -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
     bindings = list $ rest binding
-    binding :: forall t. Grammar Position (Sexp :- t) ((_, _) :- t)
+    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
     binding = list (el name >>> el rhs) >>> pair
 
 instance SexpIso Prim where

app/Main.hs

@@ -9,6 +9,8 @@ module Main
 import qualified Gyehoek.ANF as ANF
 import Gyehoek.QBE (render)
 import qualified Data.Text.IO as TIO
+import Prelude hiding ((.),id)
+import Control.Category
 
 
 main :: IO ()

gyehoek.cabal

@@ -53,6 +53,7 @@ executable gyehoek
     , vector
     , generic-lens
     , sexp-grammar
+    , invertible-grammar
 
   hs-source-dirs:   app
   default-language: GHC2024