diff --git a/app/Gyehoek/ANF.hs b/app/Gyehoek/ANF.hs index ac831e6..90392cd 100644 --- a/app/Gyehoek/ANF.hs +++ b/app/Gyehoek/ANF.hs @@ -53,6 +53,9 @@ blah' = go [] where go acc [] k = k (reverse acc) go acc (f:fs) k = f \a -> go (a:acc) fs k +telescope :: Traversable t => t ((a -> r) -> r) -> (t a -> r) -> r +telescope = runCont . traverse cont + -- 뻘짓이어라 blah :: forall t a r. Foldable t => t ((a -> r) -> r) -> (List a -> r) -> r blah xs k = @@ -67,14 +70,9 @@ toANF' toANF' (Lam.ExpVal v) k = k v toANF' (Lam.ExpApply f xs) k = - blah (toANF' <$> (f:|xs)) \(f':xs') -> do + telescope (toANF' <$> (f:|xs)) \(f':|xs') -> do r <- gensym ExpLetApply r f' xs' <$> k (ValVar r) - where - allToANF' es k = traverse (\e -> toANF' e k) es - -- blah = traverse g (f :| xs) - -- g :: Lam.Exp -> Eff es Val - -- g = ContT . toANF' toANF' e k = _ diff --git a/app/Gyehoek/Syntax.hs b/app/Gyehoek/Syntax.hs index 1b621d7..2164556 100644 --- a/app/Gyehoek/Syntax.hs +++ b/app/Gyehoek/Syntax.hs @@ -1,13 +1,22 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PartialTypeSignatures #-} module Gyehoek.Syntax where import Data.Text (Text) import Data.List (List) +import Language.SexpGrammar as Sexp hiding (List) +import Language.SexpGrammar.Generic +import GHC.Generics +import Prelude hiding ((.), id) +import Control.Category type Name = Text data Prim = PrimAdd | PrimSub | PrimMul | PrimDiv - deriving (Show) + deriving (Show, Generic) data Val = ValInt Int @@ -15,11 +24,55 @@ data Val | ValPrim Prim | ValLambda (List Name) Exp | ValVar Name - deriving (Show) + deriving (Show, Generic) data Exp = ExpLet (List (Name, Exp)) Exp | ExpApply Exp (List Exp) - | ExpProgn (List Exp) + | ExpBegin (List Exp) | ExpVal Val - deriving (Show) + deriving (Show, Generic) + + + +letIso + :: (forall t. Grammar Position (Sexp :- t) (a :- t)) + -> (forall t. Grammar Position (Sexp :- t) (b :- t)) + -> Grammar Position (Sexp :- (List (a, b) :- t1)) t2 + -> Grammar Position (Sexp :- t1) t2 +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 = list (el name >>> el rhs) >>> pair + +instance SexpIso Prim where + sexpIso = match + $ With (. sym "+") + $ With (. sym "-") + $ With (. sym "*") + $ With (. sym "/") + $ End + +instance SexpIso Val where + sexpIso = match + $ With (. sexpIso) + $ With (. sym "nil") + $ With (. sexpIso) + $ With lam + $ With (\var -> var . symbol) + $ End + where + lam q = q . list + ( el (sym "lambda") + >>> el (sexpIso @(List Name)) + >>> el sexpIso ) + +instance SexpIso Exp where + sexpIso = match + $ With (. letIso symbol sexpIso sexpIso) + $ With (\app -> app . list (el sexpIso >>> rest sexpIso)) + $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso)) + $ With (<<< sexpIso) + $ End diff --git a/gyehoek.cabal b/gyehoek.cabal index 788eb8a..c336674 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -52,6 +52,7 @@ executable gyehoek , text , vector , generic-lens + , sexp-grammar hs-source-dirs: app default-language: GHC2024