2026-05-07 09:58:43 -06:00
parent 91b3cf2870
commit 9add4ed242
3 changed files with 71 additions and 58 deletions
--- a/app/Gyehoek/ANF.hs
+++ b/app/Gyehoek/ANF.hs
@@ -22,7 +22,7 @@ import Data.Vector.Strict (Vector)
 import Data.Function (fix)
 import Effectful.Writer.Static.Local
 import Gyehoek.Syntax qualified as Lam
-import Gyehoek.Syntax (Name, Prim(..), Val(..))
+import Gyehoek.Syntax (Name, Prim(..), Lit(..))
 import Gyehoek.GenSym
 import Control.Monad.Cont
 import Data.Foldable
@@ -41,13 +41,10 @@ import Data.InvertibleGrammar.Base ((:-)((:-)))
 import qualified Gyehoek.Sexp


-- data Val
--   = ValInt Int
--   | ValNil
--   | ValPrim Prim
--   | ValLambda (List Name) Exp
--   | ValVar Name
--   deriving (Show)
+data Val
+  = ValLit Lit
+  | ValVar Name
+  deriving (Show, Generic)

 data Exp
  = ExpLetApply Name Val (List Val) Exp
@@ -69,6 +66,12 @@ collapseBindings p l e =
    Just a -> collapseBindings p l (a ^. l) & _1 %~ (a:)
    Nothing -> ([], e)

+instance SexpIso Val where
+  sexpIso = match
+    $ With (. sexpIso)
+    $ With (. symbol)
+    $ End
+
 instance SexpIso Exp where
  sexpIso = match
    $ With (. letapp)
@@ -93,26 +96,17 @@ instance SexpIso Exp where



-blah' :: List ((a -> r) -> r) -> (List a -> r) -> r
-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 =
-  foldr (\i l acc -> i \x -> l (x:acc)) (k . reverse) xs []
-
 toANF'
  :: forall es. GenSym :> es
  => Lam.Exp
  -> (Val -> Eff es Exp)
  -> Eff es Exp

-toANF' (Lam.ExpVal v) k = k v
+toANF' (Lam.ExpLit v) k = k . ValLit $ v

 toANF' (Lam.ExpApply f xs) k =
  telescope (toANF' <$> (f:|xs)) \(f':|xs') -> do
@@ -123,30 +117,25 @@ 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)
-      ]
-    ]
+-- 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)]
-    ]
+-- 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)]
+--     ]



-type CodeGen = Writer (Vector QBE.Inst)
-
-emit :: CodeGen :> es => QBE.Inst -> Eff es ()
-emit = tell . pure
-
 instance Semigroup QBE.Program where
  QBE.Program ts ds fs <> QBE.Program ts' ds' fs' =
    QBE.Program (ts <> ts') (ds <> ds') (fs <> fs')
@@ -155,7 +144,9 @@ instance Monoid QBE.Program where
  mempty :: QBE.Program
  mempty = QBE.Program mempty mempty mempty

-funcdef :: QBE.Ident QBE.Global -> [QBE.Param] -> NonEmpty QBE.Block -> FuncDef
+funcdef
+  :: QBE.Ident QBE.Global
+  -> List QBE.Param -> NonEmpty QBE.Block -> FuncDef
 funcdef name ps = QBE.FuncDef mempty Nothing name Nothing ps QBE.NoVariadic

 prims :: QBE.Program
@@ -210,10 +201,10 @@ lowerVal
  -> (QBE.Val -> Eff es BlockBuilder)
  -> Eff es BlockBuilder

-lowerVal (ValInt n) k = k . QBE.ValConst . QBE.CInt . fromIntegral $ n
+lowerVal (ValLit (LitInt n)) k =
+  k . QBE.ValConst . QBE.CInt . fromIntegral $ n
+lowerVal (ValLit _) k = error "todo"
 lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
-lowerVal (ValPrim p) k = lowerPrim p k
-lowerVal _ k = _

 lower'
  :: forall es. (GenSym :> es)
--- a/app/Gyehoek/Sexp.hs
+++ b/app/Gyehoek/Sexp.hs
@@ -13,6 +13,8 @@ import Language.SexpGrammar.Generic
 import Data.InvertibleGrammar.Base qualified as IG
 import Data.InvertibleGrammar.Base ((:-)((:-)))
 import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.List (List)
+import GHC.Generics


 nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
@@ -31,3 +33,20 @@ let_ name rhs e = list (el (sym "let") >>> el bindings >>> el e)
    bindings = nonempty binding
    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
    binding = list (el name >>> el rhs) >>> pair
+
+data DotList a = MkDotList (NonEmpty a) a
+  deriving (Show, Generic)
+
+dotlist :: Grammar Position _ _ -> _
+dotlist x = list $ rest $ coproduct
+  [ x >>> iso _ _
+  ]
+
+lambda
+  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
+  -> Grammar Position (Sexp :- List a :- t1) t2
+  -> Grammar Position (Sexp :- t1) t2
+lambda name e = list $
+  el (sym "lambda")
+  >>> el (list $ rest name)
+  >>> el e
--- a/app/Gyehoek/Syntax.hs
+++ b/app/Gyehoek/Syntax.hs
@@ -20,19 +20,20 @@ type Name = Text
 data Prim = PrimAdd | PrimSub | PrimMul | PrimDiv
  deriving (Show, Generic)

-data Val
-  = ValInt Int
-  | ValNil
-  | ValPrim Prim
-  | ValLambda (List Name) Exp
-  | ValVar Name
+data Lit
+  = LitInt Int
+  | LitNil
+  | LitBool Bool
  deriving (Show, Generic)

 data Exp
  = ExpLet (NonEmpty (Name, Exp)) Exp
  | ExpApply Exp (List Exp)
  | ExpBegin (List Exp)
-  | ExpVal Val
+  | ExpLit Lit
+  | ExpPrim Prim
+  | ExpLambda (List Name) Exp
+  | ExpVar Name
  deriving (Show, Generic)


@@ -45,24 +46,26 @@ instance SexpIso Prim where
    $ With (. sym "/")
    $ End

-instance SexpIso Val where
+instance SexpIso Lit where
  sexpIso = match
    $ With (. sexpIso)
    $ With (. sym "nil")
    $ With (. sexpIso)
-    $ With lam
-    $ With (. symbol)
    $ End
    where
-      lam q = q . list
-        ( el (sym "lambda")
-          >>> el (sexpIso @(List Name))
-          >>> el sexpIso )

 instance SexpIso Exp where
  sexpIso = match
    $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
-    $ With (<<< sexpIso)
+    $ With (. sexpIso)
+    $ With (. sexpIso)
+    $ With (. lam)
+    $ With (. symbol)
    $ End
+    where
+      lam = list
+        ( el (sym "lambda")
+          >>> el (sexpIso @(List Name))
+          >>> el sexpIso )