diff --git a/app/Gyehoek/ANF.hs b/app/Gyehoek/ANF.hs index 4c3d752..4949ff2 100644 --- a/app/Gyehoek/ANF.hs +++ b/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' - :: Foldable f => Prism' e (lhs, rhs, e) -> f (lhs, rhs) +collapseBindings + :: 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 = IG.Iso - _ - _ +-- nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t) +-- 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 = --- Lam.ExpApply (Lam.ExpVal (ValPrim PrimAdd)) --- [ Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 1)] --- , Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 2)] --- , Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 3)] --- ] +expr = + Lam.ExpPrim + (PrimAdd + (Lam.ExpPrim + (PrimMul + (Lam.ExpLit (LitInt 2)) + (Lam.ExpLit (LitInt 3)))) + (Lam.ExpLit (LitInt 4))) diff --git a/app/Gyehoek/Sexp.hs b/app/Gyehoek/Sexp.hs index c6f62d4..b4bb594 100644 --- a/app/Gyehoek/Sexp.hs +++ b/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))