diff --git a/app/Gyehoek/ANF.hs b/app/Gyehoek/ANF.hs index 90392cd..b34d174 100644 --- a/app/Gyehoek/ANF.hs +++ b/app/Gyehoek/ANF.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BlockArguments #-} @@ -30,6 +31,13 @@ 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.Generic +import GHC.Generics +import Control.Category +import Prelude hiding ((.), id) +import Data.InvertibleGrammar.Base qualified as IG +import Data.InvertibleGrammar.Base ((:-)((:-))) -- data Val @@ -42,9 +50,41 @@ import Data.String (fromString) data Exp = ExpLetApply Name Val (List Val) Exp - | ExpProgn (List Exp) + | ExpBegin (List Exp) | ExpVal Val - deriving (Show) + deriving (Show, Generic) + + + +collapseBindings + :: Prism' Exp a -> Getter a Exp -> Exp -> (List a, Exp) +collapseBindings p l e = + case e ^? p of + Just a -> collapseBindings p l (a ^. l) & _1 %~ (a:) + Nothing -> ([], e) + +instance SexpIso Exp where + sexpIso = match + $ With (. letapp) + $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso)) + $ With (. sexpIso) + $ End + where + letapp :: Grammar + Position (Sexp :- t) (Exp :- List Val :- Val :- Text :- t) + letapp = Lam.letIso symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp) + >>> IG.Iso bluh hulb + bluh (e :- ((r,f:|xs):bs) :- t) = + foldr (\(v,g:|ys) -> ExpLetApply v g ys) e bs :- xs :- f :- r :- t + bluh _ = error "empty let lol" + hulb :: (Exp :- ([Val] :- (Val :- (Text :- t)))) + -> Exp :- ([(Name, NonEmpty Val)] :- t) + hulb (e :- xs :- f :- r :- t) = e' :- ((r,f:|xs):bs) :- t + -- hulb (e :- xs :- f :- r :- t) = ExpLetApply r f xs e' :- bs :- t + where + -- (bs,e') = ([],e) + (bs,e') = collapseBindings #ExpLetApply _4 e + & _1 . each %~ \(x,g,ys,_) -> (x,g:|ys) diff --git a/app/Gyehoek/Syntax.hs b/app/Gyehoek/Syntax.hs index 2164556..e0344bf 100644 --- a/app/Gyehoek/Syntax.hs +++ b/app/Gyehoek/Syntax.hs @@ -44,7 +44,7 @@ letIso name rhs e = list (el (sym "let") >>> el bindings >>> el e) where -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _) bindings = list $ rest binding - binding :: forall t. Grammar Position (Sexp :- t) ((_, _) :- t) + binding :: Grammar Position (Sexp :- t) ((_, _) :- t) binding = list (el name >>> el rhs) >>> pair instance SexpIso Prim where diff --git a/app/Main.hs b/app/Main.hs index aa8608d..1cbce18 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,6 +9,8 @@ module Main import qualified Gyehoek.ANF as ANF import Gyehoek.QBE (render) import qualified Data.Text.IO as TIO +import Prelude hiding ((.),id) +import Control.Category main :: IO () diff --git a/gyehoek.cabal b/gyehoek.cabal index c336674..2aa59ca 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -53,6 +53,7 @@ executable gyehoek , vector , generic-lens , sexp-grammar + , invertible-grammar hs-source-dirs: app default-language: GHC2024