app/Gyehoek/ANF.hs

@@ -27,6 +27,7 @@ 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
@@ -57,7 +58,8 @@ data Exp
 
 
 collapseBindings
-  -- | Match constructor.
+  -- | Match constructor. (an affine fold would be preferable to a
+  --   prism here)
   :: Prism' a b
   -- | Extract subexpression from match.
   -> Getter b a
@@ -68,19 +70,44 @@ collapseBindings p l e =
     Just a -> collapseBindings p l (a ^. l) & _1 %~ (a:)
     Nothing -> ([], e)
 
+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 => Prism' 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 a
-  -> Lens' a lhs
-  -> Lens' a rhs
-  -> Lens' a Exp
+  :: Prism' Exp (lhs, rhs, Exp)
   -> Grammar
        Position
        (Exp :- NonEmpty (lhs, rhs) :- t)
-       (Exp :- _)
-foldLet p lhs rhs exp =
+       (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
@@ -91,6 +118,11 @@ instance SexpIso Val where
 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
+  _
+  _
+
 instance SexpIso Exp where
   sexpIso = match
     $ With (. letapp)
@@ -103,12 +135,18 @@ instance SexpIso Exp where
         :: Grammar Position (Sexp :- t) (Exp :- (Prim Val :- (Text :- t)))
       letprim =
         Gyehoek.Sexp.let_ symbol (sexpIso @(Prim Val)) (sexpIso @Exp)
-        >>> foldLet #ExpLetPrim _1 _2 _3
+        >>> 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 _1 (lensProduct _2 _3 . from nonEmptyIso) _4
+         >>> foldLet (#ExpLetApply
+                      . iso (\(rhs,f,xs,e) -> (rhs, f:|xs, e))
+                            (\(rhs,f:|xs,e) -> (rhs,f,xs,e)))
+         >>> onTail nonEmptyGrammar
+         -- >>> IG.Iso
+         --     (\(e :- (f:|xs) :- t) -> e :- f :- xs :-)
+         --     _
       -- foldLet =
       --   IG.Iso
       --     (\(e :- ((r,f:|xs):|bs) :- t) ->