app/Gyehoek/ANF.hs

@@ -31,14 +31,15 @@ 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 as Sexp hiding (List, iso)
 import Language.SexpGrammar.Generic
-import GHC.Generics
+import GHC.Generics (Generic)
 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
 
 
 data Val
@@ -48,6 +49,7 @@ data Val
 
 data Exp
   = ExpLetApply Name Val (List Val) Exp
+  | ExpLetPrim Name (Prim Val) Exp
   | ExpBegin (List Exp)
   | ExpVal Val
   deriving (Show, Generic)
@@ -66,33 +68,56 @@ collapseBindings p l e =
     Just a -> collapseBindings p l (a ^. l) & _1 %~ (a:)
     Nothing -> ([], e)
 
+foldLet
+  :: Prism' Exp a
+  -> Lens' a lhs
+  -> Lens' a rhs
+  -> Lens' a Exp
+  -> Grammar
+       Position
+       (Exp :- NonEmpty (lhs, rhs) :- t)
+       (Exp :- _)
+foldLet p lhs rhs exp =
+  IG.Iso
+    _
+    _
+
 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 (:|))
+
 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 _1 _2 _3
       letapp :: Grammar
         Position (Sexp :- t) (Exp :- List Val :- Val :- Text :- t)
       letapp =
         Gyehoek.Sexp.let_ symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp)
-         >>> foldLet
-      foldLet =
-        IG.Iso
-          (\(e :- ((r,f:|xs):|bs) :- t) ->
-             foldr (\(v,g:|ys) -> ExpLetApply v g ys) e bs
-               :- 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)
+         >>> foldLet #ExpLetApply _1 (lensProduct _2 _3 . from nonEmptyIso) _4
+      -- foldLet =
+      --   IG.Iso
+      --     (\(e :- ((r,f:|xs):|bs) :- t) ->
+      --        foldr (\(v,g:|ys) -> ExpLetApply v g ys) e bs
+      --          :- 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)
 
 
 
@@ -188,13 +213,6 @@ buildBlock n bb = QBE.Block n [] (is ^.. each) j
 lowerName :: Name -> QBE.Ident t
 lowerName = fromString . T.unpack
 
-lowerPrim :: Prim -> _ -> _
-lowerPrim PrimAdd k = k $ QBE.ValGlobal "plus"
-lowerPrim PrimMul k = k $ QBE.ValGlobal "star"
-lowerPrim PrimSub k = k $ QBE.ValGlobal "_"
-lowerPrim PrimDiv k = k $ QBE.ValGlobal "slash"
-lowerPrim p k = _
-
 lowerVal
   :: forall es. (GenSym :> es)
   => Val