expand kinda

gyehoek.cabal

@@ -70,6 +70,7 @@ library
     Gyehoek.Options
     Gyehoek.Prelude
     Gyehoek.Scheme.Expand
+    Gyehoek.Scheme.Expand.Syntax
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Sexp.Grammar

src/Gyehoek/CPS/Convert.hs

@@ -78,7 +78,7 @@ convert (Scm.ExpApply f xs) k =
 
 convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
 
-convert (Scm.ExpIf c t f) k =
+convert (Scm.ExpIf c t (Just f)) k =
   convert1 c \c' -> do
     t_l <- gensym' @Name "truthy-cont"
     f_l <- gensym' @Name "falsey-cont"

src/Gyehoek/Scheme/Expand.hs

@@ -8,7 +8,8 @@ module Gyehoek.Scheme.Expand
 import Gyehoek.Sexp.Syntax
 import Gyehoek.Sexp qualified as S
 import Gyehoek.Prelude
-import Gyehoek.Scheme.Syntax (Name (MkName), Lit(..))
+import Gyehoek.Scheme.Syntax hiding (Prim(..))
+import Gyehoek.Scheme.Syntax qualified as Scm
 import qualified Data.HashSet as HS
 import qualified Data.HashMap.Strict as H
 import Data.Foldable
@@ -32,6 +33,7 @@ import Effectful.State.Dynamic
 import Witherable
 import Data.Semigroup (Arg(..))
 import Data.Ord (Down(..))
+import qualified Data.Scientific as Sci
 
 
 data Bind
@@ -321,6 +323,15 @@ instance S.DatumIso Bind where
 
 
 
+t_prim_let :: Prism' Datum (Name, PrimLet Datum)
+t_prim_let = prism'
+  (\ (kw,MkPrimLet n bs body) ->
+    let n' = foldMap (:[]) n
+    in [S.sx|(#{kw} ##{n'} #{bs})|])
+  _
+
+
+
 -- |
 -- >>> match (PatList [PatVar "x"] Nothing (Just (PatVar "y"))) [S.sx|(1 2 . 2)|]
 -- Nothing
@@ -396,36 +407,9 @@ type Expand es = (State SymTable :> es, GenSym :> es)
 runExpand :: SymTable -> Eff (State SymTable : GenSym : es) a -> Eff es (a, SymTable)
 runExpand tab = runGenSym . runStateLocal tab
 
-testResolve :: Datum -> IO (Datum, SymTable)
+testExpand :: Datum -> IO (CommandOrDef, SymTable)
-testResolve = runJalmotIO . runExpand (symTableOfEnv env_scheme_base)
+testExpand = runJalmotIO . runExpand (symTableOfEnv env_scheme_base)
-  . resolve env_scheme_base mempty
+  . expand env_scheme_base mempty
-
-{- |
->>> :{
-  runPureEff . runExpand $ primScope mempty PrimLet [S.sx|
-    (let ((x 3)
-          (y 4))
-      (+ x y))
-  |]
-:}
--}
--- primScope
---   :: Expand es
---   => HashSet Scope -> Prim -> Datum -> Eff es (Scope, List Datum)
--- primScope scopes = \cases
---   PrimLet (List (_:bs:body)) -> do
---     newScope <- gensym
---     let scopes' = HS.insert newScope scopes
---     -- i should… i should probably add some optics to Gyehoek.Sexp…
---     forOf_
---       (dat . #_CompoundF . #_ListF . _2
---           . each . dat . #_CompoundF . #_ListF . _2 . _head
---           . dat . #_SimpleF . #_SimpleSymbol)
---       bs
---       \sym -> do
---         bind <- gensym
---         tell $ H.singleton (MkKey (MkName sym) scopes') bind
---     pure (newScope, body)
 
 -- | denotations
 data Denot
@@ -476,55 +460,6 @@ parsePrim primname d = case primname of
   "lambda" -> PrimLambda <$> run prim_lambda d
   "if" -> PrimIf <$> run prim_if d
 
-resolve
-  :: (Expand es, Jalmot :> es)
-  => Env -> HashSet Scope -> Datum -> Eff es Datum
-
-resolve g scopes (Symbol s) = do
-  (bind,_) <- lookupSymbol g scopes (MkName s)
-  pure [S.sx|#{bind}|]
-
-resolve g scopes e@(List xs)
-  | Symbol s : xs' <- xs
-  = do
-    (_,denot) <- lookupSymbol g scopes (MkName s)
-    case denot of
-      DenotVar -> _
-      DenotMacro t -> _
-      DenotPrim primname -> case parsePrim @Datum primname e of
-       Just p -> resolvePrim g scopes p
-       Nothing -> err [i|prim에서 신택스는 잘못한다: #{e}|]
-  | otherwise = List <$> traverse (resolve g scopes) xs
-
-resolvePrim
-  :: (Expand es, Jalmot :> es)
-  => Env -> HashSet Scope -> Prim Datum -> Eff es Datum
-resolvePrim g scopes (PrimLet (MkPrimLet n bs body)) = do
-  newScope <- gensym @Scope
-  let scopes' = HS.insert newScope scopes
-  n' <- traverse (resolveSymbol scopes') (foldMap (:[]) n)
-  bs' <- traverseOf (each . _1) (resolveSymbol scopes') bs
-  let g' = fold
-        [ g
-        , foldMap envOfVar n'
-        , foldMapOf (each . _1) envOfVar bs'
-        ]
-  body' <- traverse (resolve g' scopes') body
-  let n_g = [ MkKey x scopes' | x <- foldMap (:[]) n ]
-  let bs_g = [ (MkKey lhs scopes',rhs) | (lhs,rhs) <- bs ^.. each ]
-  pure [S.sx|
-    (let ##{n_g} #{bs_g}
-      ##{body'})
-  |]
-
-resolveSymbol
-  :: Expand es
-  => HashSet Scope -> Name -> Eff es Bind
-resolveSymbol scopes symbol = do
-  bind <- gensymLexical symbol
-  emit $ binding symbol scopes bind
-  pure bind
-
 emit :: (Monoid m, State m :> es) => m -> Eff es ()
 emit x = modify (<> x)
 
@@ -593,8 +528,70 @@ nearest (MkKey symbol scopes) =
     []
   >>> fmap (\(Down (Arg _ x)) -> x)
 
-denotToDatum :: Denot -> Datum
+expand
-denotToDatum = _
+  :: (Expand es, Jalmot :> es)
+  => Env -> ScopeSet -> Datum -> Eff es CommandOrDef
+
+expand g scopes datum@(List (Symbol s : es)) = do
+  let s' = MkName s
+  (_,denot) <- lookupSymbol g scopes s'
+  case denot of
+    DenotVar -> Command . ExpApply (ExpVar s')
+      <$> traverse (expandAsExp g scopes) es
+    DenotPrim x -> expandPrim g scopes x datum
+
+-- 신기하지 않은 경우들
+expand g scopes datum = case datum of
+  List (x:xs) -> Command <$> (ExpApply <$> go x <*> traverse go xs)
+  Symbol s -> pure . Command . ExpVar . MkName $ s
+  Boolean b -> lit $ LitBool b
+  Number (Sci.floatingOrInteger -> Right n) -> lit $ LitInt n
+  where
+    go = expandAsExp g scopes
+    lit = pure . Command . ExpLit
+
+expandPrim 
+  :: (Expand es, Jalmot :> es)
+  => Env -> ScopeSet -> Name -> Datum -> Eff es CommandOrDef
+expandPrim g scopes primName datum
+  | Just prim <- parsePrim @Datum primName datum
+  = case prim of
+    PrimLet (MkPrimLet Nothing bs [body]) -> do
+      scopes' <- flip HS.insert scopes <$> gensym
+      g' <- (g<>) . fold <$> for (bs ^.. each . _1) \x ->
+        bindLexical scopes' x DenotVar
+      Command <$> (ExpLet
+        <$> traverseOf (each . _2) (expandAsExp g scopes) bs
+        <*> expandAsExp g scopes' body)
+    PrimLambda (MkPrimLambda (FormalsFixed xs) [body]) -> do
+      scopes' <- flip HS.insert scopes <$> gensym
+      g' <- (g<>) . fold <$> for xs \x -> bindLexical scopes' x DenotVar
+      Command . ExpLambda xs <$> expandAsExp g' scopes' body
+    PrimIf (MkPrimIf c t f) ->
+      Command <$> (ExpIf
+        <$> expandAsExp g scopes c
+        <*> expandAsExp g scopes t
+        <*> traverse (expandAsExp g scopes) f
+        )
+  | otherwise = err [i|prim #{primName}에 잘못한 신택스: #{datum}|]
+
+expandAsExp
+  :: (Expand es, Jalmot :> es)
+  => Env -> ScopeSet -> Datum -> Eff es Exp
+expandAsExp g scopes d = expand g scopes d >>= intoExp
+
+bindLexical :: Expand es => ScopeSet -> Name -> Denot -> Eff es Env
+bindLexical scopes symbol denot = do
+  identity <- gensym
+  let bind = BindLexical {symbol,identity}
+  modify (<> binding symbol scopes bind)
+  pure $ MkEnv (H.singleton bind denot)
+
+intoExp :: Jalmot :> es => CommandOrDef -> Eff es Exp
+intoExp (Command e) = pure e
+intoExp (Begin es) = traverse intoExp es >>= \case
+  [] -> err "begin expression은 빔"
+  (x:xs) -> pure . ExpBegin $ x NE.:| xs
 
 
 

src/Gyehoek/Scheme/Expand/Syntax.hs

@@ -0,0 +1,9 @@
+module Gyehoek.Scheme.Expand.Syntax
+  (
+  ) where
+
+import Gyehoek.Scheme.Syntax (Name (MkName), Lit(..))
+import Gyehoek.Sexp.Syntax
+import Gyehoek.Sexp qualified as S
+import Gyehoek.Prelude
+

src/Gyehoek/Scheme/Syntax.hs

@@ -118,7 +118,7 @@ data Exp
   | ExpLetRec (List (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
   | ExpBegin (NonEmpty Exp)
-  | ExpIf Exp Exp Exp
+  | ExpIf Exp Exp (Maybe Exp)
   | ExpLit Lit
   | ExpLambda (List Name) Exp
   | ExpVar Name