app/Gyehoek/ANF.hs

@@ -32,9 +32,10 @@ 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)
+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
@@ -57,19 +58,6 @@ data Exp
 
 
 
-collapseBindings
-  -- | Match constructor. (an affine fold would be preferable to a
-  --   prism here)
-  :: 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:)
-    Nothing -> ([], e)
-
 expandBindings
   -- | Match constructor. (an affine fold would be preferable to a
   --   prism here)
@@ -82,10 +70,10 @@ expandBindings p = go [] where
       Just (l,r,e') -> go ((l,r):acc) e'
       Nothing -> (acc, e)
 
-collapseBindings'
+collapseBindings
-  :: Foldable f => Prism' e (lhs, rhs, e) -> f (lhs, rhs)
+  :: 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
+collapseBindings p bs e = foldr (\(l,r) e' -> p # (l,r,e')) e bs
 
 -- | Technically unlawful.
 bindingTelescope
@@ -93,7 +81,7 @@ bindingTelescope
   -> Iso' e (List (lhs, rhs), e)
 bindingTelescope p = iso
   (expandBindings p)
-  (uncurry $ collapseBindings' p)
+  (uncurry $ collapseBindings p)
 
 foldLet
   :: Prism' Exp (lhs, rhs, Exp)
@@ -104,7 +92,7 @@ foldLet
 foldLet p =
   IG.Iso
     (\(e :- ((l1,r1):|bs) :- t) ->
-       collapseBindings' p bs e :- r1 :- l1 :- t)
+       collapseBindings p bs e :- r1 :- l1 :- t)
     (\(e :- r :- l :- t) ->
        let (bs,e') = expandBindings p e
        in e' :- ((l,r) :| bs) :- t)
@@ -118,10 +106,10 @@ 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 :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
-nonEmptyGrammar = IG.Iso
+-- nonEmptyGrammar = IG.Iso
-  _
+--   (\((x:|xs) :- t) -> xs :- x :- t)
-  _
+--   (\(xs :- x :- t) -> (x:|xs) :- t)
 
 instance SexpIso Exp where
   sexpIso = match
@@ -144,18 +132,6 @@ instance SexpIso Exp where
                       . 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) ->
-      --        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)
 
 
 
@@ -170,6 +146,10 @@ toANF'
   -> 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
@@ -180,22 +160,16 @@ toANF' e k = _
 
 toANF e = toANF' e (pure . ExpVal)
 
--- expr =
+
---   Lam.ExpApply (Lam.ExpVal (ValPrim PrimAdd))
---     [ Lam.ExpVal (ValInt 1)
---     , Lam.ExpApply
---       (Lam.ExpVal (ValPrim PrimMul))
---       [ Lam.ExpVal (ValInt 2)
---       , Lam.ExpVal (ValInt 4)
---       ]
---     ]
 
--- expr2 =
+expr =
---   Lam.ExpApply (Lam.ExpVal (ValPrim PrimAdd))
+  Lam.ExpPrim
---     [ Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 1)]
+    (PrimAdd
---     , Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 2)]
+     (Lam.ExpPrim
---     , Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 3)]
+      (PrimMul
---     ]
+       (Lam.ExpLit (LitInt 2))
+       (Lam.ExpLit (LitInt 3))))
+    (Lam.ExpLit (LitInt 4)))
 
 
 

app/Gyehoek/Sexp.hs

@@ -4,23 +4,41 @@
 module Gyehoek.Sexp
   ( let_
   , nonempty
+  , nonEmptyGrammar
+  , encode
+  , decode
   )
 where
 
 import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (List)
+import Language.SexpGrammar as Sexp hiding (List, encode, decode)
+import Language.SexpGrammar qualified as Sexp
 import Language.SexpGrammar.Generic
-import Data.InvertibleGrammar.Base qualified as IG
+import Data.InvertibleGrammar.Base qualified as IGB
+import Data.InvertibleGrammar qualified as IG
 import Data.InvertibleGrammar.Base ((:-)((:-)))
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.List (List)
-import GHC.Generics
+import Data.Text.Encoding
+import GHC.Generics (Generic)
+import Control.Lens
 
 
+encode :: SexpIso a => a -> Either _ Text
+encode = (_Right %~ decodeUtf8 . view strict) . Sexp.encode
+
+decode :: SexpIso a => Text -> Either String a
+decode = Sexp.decode . view lazy . encodeUtf8
+
+nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
+nonEmptyGrammar = IGB.Iso
+  (\((x:|xs) :- t) -> xs :- x :- t)
+  (\(xs :- x :- t) -> (x:|xs) :- t)
+
 nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
 nonempty a =
   list (el a >>> rest a) >>>
-    pair >>> iso (uncurry (:|)) (\(x :| xs) -> (x, xs))
+    IG.flipped nonEmptyGrammar
 
 let_
   :: (forall t. Grammar Position (Sexp :- t) (a :- t))