diff --git a/app/Gyehoek/ANF.hs b/app/Gyehoek/ANF.hs index 11ab4e2..4c3d752 100644 --- a/app/Gyehoek/ANF.hs +++ b/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) ->