diff --git a/src/Gyehoek/Scheme/Expand.hs b/src/Gyehoek/Scheme/Expand.hs index 963fae2..8789791 100644 --- a/src/Gyehoek/Scheme/Expand.hs +++ b/src/Gyehoek/Scheme/Expand.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TypeFamilies #-} module Gyehoek.Scheme.Expand ( ) where @@ -6,7 +8,7 @@ module Gyehoek.Scheme.Expand import Gyehoek.Sexp.Syntax import Gyehoek.Sexp qualified as S import Gyehoek.Prelude -import Gyehoek.Scheme.Syntax (Name, Lit(..)) +import Gyehoek.Scheme.Syntax (Name (MkName), Lit(..)) import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as H import Data.Foldable @@ -18,23 +20,53 @@ 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) +import GHC.Exts (IsList(..)) +import Gyehoek.Jalmot +import Data.Maybe (isNothing) +import Data.Kind (Type) +import Data.Traversable (for) +data Bind + = BindLexical { symbol :: Name, identity :: Natural } + | BindGlobal { symbol :: Name } + deriving stock (Generic, Eq, Show) + deriving anyclass (Hashable) + data Scope = MkScope - { identity :: Natural - , bindings :: HashSet Name + { name :: Name + , identity :: Natural } + deriving stock (Show, Generic, Eq, Ord) + deriving anyclass (Hashable) + +instance Gen Scope where + gen = MkScope "" + gen' s = MkScope (MkName s) + +data Formals + = FormalsFixed (List Name) + | FormalsRest (List Name) Name deriving (Show, Generic) -data Syntax - = SyntaxTrans Trans - | SyntaxPrim Prim - deriving (Show, Generic) +data PrimLambda e = MkPrimLambda Formals (List e) + deriving (Show, Generic, Functor, Foldable, Traversable) +data PrimLet e = MkPrimLet (Maybe Name) (List (Name, e)) (List e) + deriving (Show, Generic, Functor, Foldable, Traversable) +data PrimIf e = MkPrimIf e e (Maybe e) + deriving (Show, Generic, Functor, Foldable, Traversable) +data PrimLetSyntax e = MkPrimLetSyntax (List (Name, Trans)) (List e) + deriving (Show, Generic, Functor, Foldable, Traversable) -data Prim - = PrimLambda - | PrimLet - | PrimIf +data Prim e + = PrimLambda (PrimLambda e) + | PrimLet (PrimLet e) + | PrimIf (PrimIf e) + | PrimLetSyntax (PrimLetSyntax e) deriving (Show, Generic) data Trans = MkTrans @@ -84,6 +116,10 @@ data El | El Tem deriving (Show, Generic) +data Key = MkKey Name (HashSet Scope) + deriving stock (Show, Generic, Eq) + deriving anyclass (Hashable) + instance S.DatumIso Trans where @@ -191,6 +227,101 @@ instance S.DatumIso Tem where affixEllipses (x : xs) = (x,False) : affixEllipses xs affixEllipses [] = [] +instance S.DatumIso Scope where + datumIso = S.with \g -> + S.list (S.el S.datumIso >>> S.el S.datumIso) + >>> g + +hashSetGrammar + :: forall a. (Hashable a, Ord a) + => S.DatumGrammar a -> S.DatumGrammar (HashSet a) +hashSetGrammar g = + S.list (S.rest g) + >>> S.iso HS.fromList (sort . HS.toList) + +instance S.DatumIso Key where + datumIso = S.with \g -> + S.list + ( S.el (S.symBuiltin "@") + >>> S.el (S.datumIso @Name) + >>> S.el (hashSetGrammar S.datumIso) + ) + >>> g + +instance S.DatumIso Formals where + datumIso = S.match + $ S.With (fixed >>>) + $ S.With (rest >>>) + $ S.End + where + fixed :: S.G (Datum :- t) (List Name :- t) + fixed = S.list $ S.rest $ S.datumIso @Name + rest :: S.G (Datum :- t) (Name :- List Name :- t) + rest = S.coproduct + [ S.dottedList (S.rest $ S.datumIso @Name) (S.datumIso @Name) + , S.datumIso @Name >>> S.onTail (S.push [] null (const mempty)) + ] + +optEl + :: S.G (S.Datum :- t) (a :- t) + -> S.G (S.ListContext :- t) (S.ListContext :- Maybe a :- t) +optEl g = + S.coproduct + [ S.el g >>> S.onTail (S.partialIso Just \case + Nothing -> Left mempty + Just x -> Right x) + , S.onTail $ S.push Nothing isNothing (const mempty) + ] + +anykw :: Text -> S.G (Datum :- t) t +anykw s = S.Flip $ S.PartialIso + (\t -> (Symbol s & ann . #syntax .~ SynBuiltin) :- t) + \case + (Symbol _ :- t) -> Right t + _ -> Left $ S.expected "symbol" + +prim_if :: S.DatumIso e => S.DatumGrammar (PrimIf e) +prim_if = S.with \g -> + S.listWithIndentation (NSpecial 1) + (S.el (anykw "if") + >>> S.el S.datumIso + >>> S.el S.datumIso + >>> optEl S.datumIso) + >>> g + +prim_lambda :: S.DatumIso e => S.DatumGrammar (PrimLambda e) +prim_lambda = S.with \g -> + S.lambdaLike (anykw "λ") (S.datumIso @Formals) (S.rest S.datumIso) + >>> g + +prim_let + :: forall e. S.DatumIso e => S.DatumGrammar (PrimLet e) +prim_let = S.with \g -> + (S.listWithIndentation (NSpecial 1) $ + S.el (anykw "let") + >>> optEl (S.datumIso @Name) + >>> S.el (S.list $ S.rest $ S.datumIso @(Name,e)) + >>> S.rest S.datumIso) + >>> g + +prim_let_syntax :: S.DatumIso e => S.DatumGrammar (PrimLetSyntax e) +prim_let_syntax = S.with \g -> + (S.listWithIndentation (NSpecial 1) $ + S.el (anykw "let-syntax") + >>> S.el (S.list $ S.rest $ S.datumIso @(Name,Trans)) + >>> S.rest S.datumIso) + >>> g + +instance S.DatumIso Bind where + datumIso = S.match + $ S.With (\g -> + S.list (S.el (S.symBuiltin "L") >>> S.el S.datumIso >>> S.el S.datumIso) + >>> g) + $ S.With (\g -> + S.list (S.el (S.symBuiltin "G") >>> S.el S.datumIso) + >>> g) + $ S.End + -- | @@ -247,6 +378,150 @@ matchThese _ = empty +type SymTable = HashMap Key Bind + +type Expand es = (Writer SymTable :> es, GenSym :> es) + +runExpand :: Eff (Writer SymTable : GenSym : es) a -> Eff es (a, SymTable) +runExpand = runGenSym . runWriter + +{- | +>>> :{ + 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 + = DenotVar + | DenotMacro Trans + | DenotPrim Name + deriving stock (Show, Generic) + +newtype Env = MkEnv { names :: HashMap Bind Denot } + deriving stock (Show, Generic) + deriving newtype (Semigroup, Monoid) + +-- | @(environment '(scheme base))@ +env_scheme_base :: Env +env_scheme_base = MkEnv . fromList . fold $ + [ [ (BindGlobal p, DenotPrim p) | p <- prims ] + , [ (BindGlobal "λ", DenotPrim "lambda") + ] + ] + where + prims = + [ "if" + , "lambda" + , "let" + , "let-syntax" + ] + +type instance IxValue Env = Denot +type instance Index Env = Bind + +instance Ixed Env where ix j = #names . ix j +instance At Env where at j = #names . at j + +err :: Jalmot :> es => Text -> Eff es a +err = throwError . EvalError + +run :: S.DatumGrammar a -> Datum -> Maybe a +run g = preview #_Right . runPureEff . runJalmot . S.fromDatum g + +parsePrim :: S.DatumIso e => Name -> Datum -> Maybe (Prim e) +parsePrim primname d = case primname of + "let" -> PrimLet <$> run prim_let d + "let-syntax" -> PrimLetSyntax <$> run prim_let_syntax d + "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) = case lookupSymbol g scopes s of + Just (bind,_) -> pure [S.sx|#{bind}|] + Nothing -> err [i|심벌 #{s}가 정의되지 않다|] + +resolve g scopes e@(List xs) + | Symbol s : xs' <- xs + , Just (_,denot) <- lookupSymbol g scopes 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 + pure [S.sx| + (let ##{n'} #{bs} + ##{body'}) + |] + +resolveSymbol + :: (Expand es) + => HashSet Scope -> Name -> Eff es Bind +resolveSymbol scopes symbol = do + let key = MkKey symbol scopes + bind <- gensymLexical symbol + tell $ H.singleton key bind + pure bind + +envOfVar :: Bind -> Env +envOfVar = MkEnv . flip H.singleton DenotVar + +gensymLexical :: GenSym :> es => Name -> Eff es Bind +gensymLexical symbol = do + identity <- gensym + pure $ BindLexical {symbol,identity} + +lookupSymbol + :: Env -> HashSet Scope -> Text -> Maybe (Bind, Denot) +lookupSymbol g scopes x = g ^? + failing (iix (BindGlobal $ MkName x)) (iix (BindGlobal $ MkName x)) . withIndex + +denotToDatum :: Denot -> Datum +denotToDatum = _ + + + trans_when :: Trans trans_when = MkTrans { ellipsis = "..." diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index a945cab..47d1a11 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -179,6 +179,14 @@ instance DatumIso Bool where datumIso = boolean instance DatumIso Int where datumIso = int +instance DatumIso Natural where + datumIso = int + >>> partialOsi + (\x -> if x < 0 + then Left $ expected "non-negative integer" <> unexpected [i|#{x}|] + else Right $ fromIntegral x) + fromIntegral + instance DatumIso Datum where datumIso = Control.Category.id instance DatumIso a => DataIso (List a) where diff --git a/src/Gyehoek/Sexp/Grammar/Base.hs b/src/Gyehoek/Sexp/Grammar/Base.hs index 8a33b2b..cb713ac 100644 --- a/src/Gyehoek/Sexp/Grammar/Base.hs +++ b/src/Gyehoek/Sexp/Grammar/Base.hs @@ -428,7 +428,7 @@ letLike :: Text -> (forall t. G (Datum :- t) (a :- t)) -> (forall t. G (Datum :- t) (b :- t)) - -> G (Datum :- (List (a, b) :- t1)) t2 + -> G (Datum :- List (a, b) :- t1) t2 -> G (Datum :- t1) t2 letLike kw name rhs e = listWithIndentation (NSpecial 1) $ el (symBuiltin kw) >>> el bindings >>> el e diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index 8ebaca9..f8d5b4f 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -39,6 +39,7 @@ module Gyehoek.Sexp.Syntax , Ann(..) , noAnn , ann + , dat , pattern List' , position , stripAnn @@ -152,12 +153,22 @@ deriveEq1 ''CompoundF deriveShow1 ''DatumF deriveEq1 ''DatumF + +--- optics + +-- affine +cdr :: Traversal' Datum Datum +cdr k (a :< CompoundF (ListF ind xs)) = _ + --- modification and extraction of annotations ann :: Lens' Datum Ann ann = _extract +dat :: Lens' Datum (DatumF Datum) +dat = _unwrap + syntax :: Lens' Datum Syn syntax = ann . #syntax diff --git a/t.scm b/t.scm index 8cd1be1..c4b2cfb 100644 --- a/t.scm +++ b/t.scm @@ -1 +1,4 @@ -(define lambda 123) +(import (scheme eval)) + +(eval '(λ (x) x) + (environment))