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
+  { name :: Name
-  , bindings :: HashSet 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
+data PrimLambda e = MkPrimLambda Formals (List e)
-  = SyntaxTrans Trans
+  deriving (Show, Generic, Functor, Foldable, Traversable)
-  | SyntaxPrim Prim
+data PrimLet e = MkPrimLet (Maybe Name) (List (Name, e)) (List e)
-  deriving (Show, Generic)
+  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
+data Prim e
-  = PrimLambda
+  = PrimLambda (PrimLambda e)
-  | PrimLet
+  | PrimLet (PrimLet e)
-  | PrimIf
+  | 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 = "..."

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

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

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
 

t.scm

@@ -1 +1,4 @@
-(define lambda 123)
+(import (scheme eval))
+
+(eval '(λ (x) x)
+      (environment))