works kinda

src/Gyehoek/Scheme/Expand.hs

@@ -20,7 +20,6 @@ import Data.Monoid (Ap(Ap, getAp))
 import Gyehoek.Sexp.Grammar.Base ((:-)(..))
 import Control.Lens.Extras (is)
 import Control.Applicative (Alternative(..))
-import Effectful.Writer.Static.Shared
 import Gyehoek.GenSym
 import Data.HashSet.Lens (setOf)
 import Data.List (sort)
@@ -29,7 +28,7 @@ import Gyehoek.Jalmot
 import Data.Maybe (isNothing)
 import Data.Kind (Type)
 import Data.Traversable (for, mapAccumR)
-import Effectful.State.Static.Shared
+import Effectful.State.Dynamic
 import Witherable
 import Data.Semigroup (Arg(..))
 import Data.Ord (Down(..))
@@ -44,6 +43,7 @@ data Bind
 newtype Scope = MkScope { identity :: Natural }
   deriving stock (Show, Generic, Eq, Ord)
   deriving anyclass (Hashable)
+  deriving newtype (Gen)
 
 type ScopeSet = HashSet Scope
 
@@ -227,9 +227,7 @@ instance S.DatumIso Tem where
       affixEllipses [] = []
 
 instance S.DatumIso Scope where
-  datumIso = S.with \g ->
+  datumIso = S.with (S.datumIso >>>)
-    S.list (S.el S.datumIso >>> S.el S.datumIso)
-    >>> g
 
 hashSetGrammar
   :: forall a. (Hashable a, Ord a)
@@ -274,7 +272,7 @@ optEl g =
 
 anykw :: Text -> S.G (Datum :- t) t
 anykw s = S.Flip $ S.PartialIso
-  (\t -> (Symbol s & ann . #syntax .~ SynBuiltin) :- t)
+  (\t -> adorn SynBuiltin (Symbol s) :- t)
   \case
     (Symbol _ :- t) -> Right t
     _ -> Left $ S.expected "symbol"
@@ -395,8 +393,12 @@ instance Monoid SymTable where mempty = MkSymTable mempty
 
 type Expand es = (State SymTable :> es, GenSym :> es)
 
-runExpand :: Eff (State SymTable : GenSym : es) a -> Eff es (a, SymTable)
+runExpand :: SymTable -> Eff (State SymTable : GenSym : es) a -> Eff es (a, SymTable)
-runExpand = runGenSym . runState mempty
+runExpand tab = runGenSym . runStateLocal tab
+
+testResolve :: Datum -> IO (Datum, SymTable)
+testResolve = runJalmotIO . runExpand (symTableOfEnv env_scheme_base)
+  . resolve env_scheme_base mempty
 
 {- |
 >>> :{
@@ -451,6 +453,10 @@ env_scheme_base = MkEnv . fromList . fold $
       , "let-syntax"
       ]
 
+symTableOfEnv :: Env -> SymTable
+symTableOfEnv = ifoldMapOf (#names . itraversed) \cases
+  b@(BindGlobal n) d -> binding n mempty b
+
 type instance IxValue Env = Denot
 type instance Index Env = Bind
 
@@ -474,19 +480,20 @@ resolve
   :: (Expand es, Jalmot :> es)
   => Env -> HashSet Scope -> Datum -> Eff es Datum
 
-resolve g scopes (Symbol s) = case lookupSymbol g scopes s of
+resolve g scopes (Symbol s) = do
-  Just (bind,_) -> pure [S.sx|#{bind}|]
+  (bind,_) <- lookupSymbol g scopes (MkName s)
-  Nothing -> err [i|심벌 #{s}가 정의되지 않다|]
+  pure [S.sx|#{bind}|]
 
 resolve g scopes e@(List xs)
   | Symbol s : xs' <- xs
-  , Just (_,denot) <- lookupSymbol g scopes s
+  = do
-  = case denot of
+    (_,denot) <- lookupSymbol g scopes (MkName s)
-    DenotVar -> _
+    case denot of
-    DenotMacro t -> _
+      DenotVar -> _
-    DenotPrim primname -> case parsePrim @Datum primname e of
+      DenotMacro t -> _
-     Just p -> resolvePrim g scopes p
+      DenotPrim primname -> case parsePrim @Datum primname e of
-     Nothing -> err [i|prim에서 신택스는 잘못한다: #{e}|]
+       Just p -> resolvePrim g scopes p
+       Nothing -> err [i|prim에서 신택스는 잘못한다: #{e}|]
   | otherwise = List <$> traverse (resolve g scopes) xs
 
 resolvePrim
@@ -504,7 +511,7 @@ resolvePrim g scopes (PrimLet (MkPrimLet n bs body)) = do
         ]
   body' <- traverse (resolve g' scopes') body
   let n_g = [ MkKey x scopes' | x <- foldMap (:[]) n ]
-  let bs_g = [ MkKey x scopes | x <- bs ^.. each . _1 ]
+  let bs_g = [ (MkKey lhs scopes',rhs) | (lhs,rhs) <- bs ^.. each ]
   pure [S.sx|
     (let ##{n_g} #{bs_g}
       ##{body'})
@@ -533,10 +540,10 @@ gensymLexical symbol = do
   pure $ BindLexical {symbol,identity}
 
 lookupSymbol
-  :: (State SymTable :> es, Jalmot :> es)
+  :: forall es. (State SymTable :> es, Jalmot :> es)
   => Env -> HashSet Scope -> Name -> Eff es (Bind, Denot)
 lookupSymbol g scopes x = do
-  ss <- fmap fold . preuse @SymTable $ ix x
+  ss <- fmap fold . preuse @SymTable @(Eff es) $ ix x
   case nearest (MkKey x scopes) (H.keys ss) of
     [] -> err [i|심벌 #{x}는 정의되지 않다|]
     (_:_:_) -> err [i|심벌 #{x}는 모호하다|]