app/Gyehoek/ANF.hs

@@ -38,6 +38,7 @@ import Control.Category
 import Prelude hiding ((.), id)
 import Data.InvertibleGrammar.Base qualified as IG
 import Data.InvertibleGrammar.Base ((:-)((:-)))
+import qualified Gyehoek.Sexp
 
 
 -- data Val
@@ -57,7 +58,12 @@ data Exp
 
 
 collapseBindings
-  :: Prism' Exp a -> Getter a Exp -> Exp -> (List a, Exp)
+  -- | Match constructor.
+  :: Prism' a b
+  -- | Extract subexpression from match.
+  -> Getter b a
+  -> a
+  -> (List b, a)
 collapseBindings p l e =
   case e ^? p of
     Just a -> collapseBindings p l (a ^. l) & _1 %~ (a:)
@@ -72,15 +78,18 @@ instance SexpIso Exp where
     where
       letapp :: Grammar
         Position (Sexp :- t) (Exp :- List Val :- Val :- Text :- t)
-      letapp = Lam.letIso symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp)
+      letapp =
-         >>> IG.Iso bluh hulb
+        Gyehoek.Sexp.let_ symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp)
-      bluh (e :- ((r,f:|xs):|bs) :- t) =
+         >>> foldLet
-        foldr (\(v,g:|ys) -> ExpLetApply v g ys) e bs :- xs :- f :- r :- t
+      foldLet =
-      hulb (e :- xs :- f :- r :- t) = e' :- ((r,f:|xs):|bs) :- t
+        IG.Iso
-        where
+          (\(e :- ((r,f:|xs):|bs) :- t) ->
-          -- (bs,e') = ([],e)
+             foldr (\(v,g:|ys) -> ExpLetApply v g ys) e bs
-          (bs,e') = collapseBindings #ExpLetApply _4 e
+               :- xs :- f :- r :- t)
+          (\(e :- xs :- f :- r :- t) ->
+             let (bs,e') = collapseBindings #ExpLetApply _4 e
                            & _1 . each %~ \(x,g,ys,_) -> (x,g:|ys)
+             in e' :- ((r,f:|xs):|bs) :- t)
 
 
 

app/Gyehoek/Sexp.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Gyehoek.Sexp
+  ( let_
+  , nonempty
+  )
+where
+
+import Data.Text (Text)
+import Language.SexpGrammar as Sexp hiding (List)
+import Language.SexpGrammar.Generic
+import Data.InvertibleGrammar.Base qualified as IG
+import Data.InvertibleGrammar.Base ((:-)((:-)))
+import Data.List.NonEmpty (NonEmpty ((:|)))
+
+
+nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
+nonempty a =
+  list (el a >>> rest a) >>>
+    pair >>> iso (uncurry (:|)) (\(x :| xs) -> (x, xs))
+
+let_
+  :: (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)
+  where
+    -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
+    bindings = nonempty binding
+    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
+    binding = list (el name >>> el rhs) >>> pair

app/Gyehoek/Syntax.hs

@@ -12,6 +12,7 @@ import GHC.Generics
 import Prelude hiding ((.), id)
 import Control.Category
 import Data.List.NonEmpty (NonEmpty ((:|)))
+import Gyehoek.Sexp qualified
 
 
 type Name = Text
@@ -36,23 +37,6 @@ data Exp
 
 
 
-nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
-nonempty a =
-  list (el a >>> rest a) >>>
-    pair >>> iso (uncurry (:|)) (\(x :| xs) -> (x, xs))
-
-letIso
-  :: (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
-letIso name rhs e = list (el (sym "let") >>> el bindings >>> el e)
-  where
-    -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
-    bindings = nonempty binding
-    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
-    binding = list (el name >>> el rhs) >>> pair
-
 instance SexpIso Prim where
   sexpIso = match
     $ With (. sym "+")
@@ -67,7 +51,7 @@ instance SexpIso Val where
     $ With (. sym "nil")
     $ With (. sexpIso)
     $ With lam
-    $ With (\var -> var . symbol)
+    $ With (. symbol)
     $ End
     where
       lam q = q . list
@@ -77,7 +61,7 @@ instance SexpIso Val where
 
 instance SexpIso Exp where
   sexpIso = match
-    $ With (. letIso symbol sexpIso sexpIso)
+    $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
     $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (<<< sexpIso)

flake.nix

@@ -40,6 +40,7 @@
                 gcc
                 qbe
                 haskellPackages.cabal-fmt
+                schemat
               ];
             };
           };

gyehoek.cabal

@@ -30,6 +30,7 @@ executable gyehoek
   -- cabal-fmt: expand app -Main
   other-modules:
     Gyehoek.ANF
+    Gyehoek.Sexp
     Gyehoek.GenSym
     Gyehoek.QBE
     Gyehoek.QBE.Parse