diff --git a/gyehoek.cabal b/gyehoek.cabal index 4499135..238c695 100644 --- a/gyehoek.cabal +++ b/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 diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index a3da431..99754e5 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/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" diff --git a/src/Gyehoek/Scheme/Expand.hs b/src/Gyehoek/Scheme/Expand.hs index 1f7f6d5..7bfa994 100644 --- a/src/Gyehoek/Scheme/Expand.hs +++ b/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) -testResolve = runJalmotIO . runExpand (symTableOfEnv env_scheme_base) - . resolve 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) +testExpand :: Datum -> IO (CommandOrDef, SymTable) +testExpand = runJalmotIO . runExpand (symTableOfEnv env_scheme_base) + . expand env_scheme_base mempty -- | 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 -denotToDatum = _ +expand + :: (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 diff --git a/src/Gyehoek/Scheme/Expand/Syntax.hs b/src/Gyehoek/Scheme/Expand/Syntax.hs new file mode 100644 index 0000000..1fdaf13 --- /dev/null +++ b/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 + diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 5124141..de8a243 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/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