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
+data Val
---   = ValInt Int
+  = ValLit Lit
---   | ValNil
+  | ValVar Name
---   | ValPrim Prim
+  deriving (Show, Generic)
---   | ValLambda (List Name) Exp
---   | ValVar Name
---   deriving (Show)
 
 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 =
+-- expr =
-  Lam.ExpApply (Lam.ExpVal (ValPrim PrimAdd))
+--   Lam.ExpApply (Lam.ExpVal (ValPrim PrimAdd))
-    [ Lam.ExpVal (ValInt 1)
+--     [ Lam.ExpVal (ValInt 1)
-    , Lam.ExpApply
+--     , Lam.ExpApply
-      (Lam.ExpVal (ValPrim PrimMul))
+--       (Lam.ExpVal (ValPrim PrimMul))
-      [ Lam.ExpVal (ValInt 2)
+--       [ Lam.ExpVal (ValInt 2)
-      , Lam.ExpVal (ValInt 4)
+--       , Lam.ExpVal (ValInt 4)
-      ]
+--       ]
-    ]
+--     ]
 
-expr2 =
+-- expr2 =
-  Lam.ExpApply (Lam.ExpVal (ValPrim PrimAdd))
+--   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 1)]
-    , Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 2)]
+--     , Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 2)]
-    , Lam.ExpApply (Lam.ExpVal (ValPrim PrimMul)) [Lam.ExpVal (ValInt 3)]
+--     , 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)

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

app/Gyehoek/Syntax.hs

@@ -20,19 +20,20 @@ type Name = Text
 data Prim = PrimAdd | PrimSub | PrimMul | PrimDiv
   deriving (Show, Generic)
 
-data Val
+data Lit
-  = ValInt Int
+  = LitInt Int
-  | ValNil
+  | LitNil
-  | ValPrim Prim
+  | LitBool Bool
-  | ValLambda (List Name) Exp
-  | ValVar Name
   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 )