prim → builtin

gyehoek.cabal

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

src/Gyehoek/CPS/Convert.hs

@@ -46,7 +46,7 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   LitBool b -> ImmBool b
   _ -> _
 
-convert (Scm.ExpPrim p) k =
+convert (Scm.ExpBuiltin p) k =
   telescope (convert1 @es) p \p' -> do
     r_l <- gensym' "r"
     -- k_l <- gensym' @Name "prim-k"

src/Gyehoek/CPS/Eval.hs

@@ -226,7 +226,7 @@ eval g dps (ExpLetRec bs e) = do
   traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
   eval g' dps e
 
-eval g dps (ExpPrim (PrimCallCC withcc) k) = do
+eval g dps (ExpBuiltin (BuiltinCallCC withcc) k) = do
   withcc' <- evalVal g withcc >>= orWrong #_EProcedure
     [i|call/cc: 함수가 아닌 것을 받았다|]
   k' <- evalKexp g k
@@ -236,8 +236,8 @@ eval g dps (ExpPrim (PrimCallCC withcc) k) = do
         Nothing -> wrong [i|call/cc: 잘못하는데!|]
   withcc' [cc,k'] dps
 
-eval g dps (ExpPrim p k) = do
+eval g dps (ExpBuiltin p k) = do
-  p' <- evalPrim g dps =<< traverse (evalVal g) p
+  p' <- evalBuiltin g dps =<< traverse (evalVal g) p
   evalKexp g k >>= \case
     EProcedure fp -> fp p' dps
     _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
@@ -251,20 +251,20 @@ eval g dps (ExpIf c t f) = do
 
 eval g dps e = error [i|unimplemented #{e}|]
 
-evalPrim :: Env -> DynPoints -> Prim E -> M Answer (List E)
+evalBuiltin :: Env -> DynPoints -> Builtin E -> M Answer (List E)
-evalPrim g dps = \case
+evalBuiltin g dps = \case
-  PrimAdd x y -> arith2 (+) x y
+  BuiltinAdd x y -> arith2 (+) x y
-  PrimMul x y -> arith2 (*) x y
+  BuiltinMul x y -> arith2 (*) x y
-  PrimSub x y -> arith2 (-) x y
+  BuiltinSub x y -> arith2 (-) x y
-  PrimDiv x y -> arith2 div x y
+  BuiltinDiv x y -> arith2 div x y
-  PrimZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0
+  BuiltinZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0
-  PrimCons x y -> pcons x y >>= pure1
+  BuiltinCons x y -> pcons x y >>= pure1
-  PrimCar p -> cr p _2
+  BuiltinCar p -> cr p _2
-  PrimCdr p -> cr p _3
+  BuiltinCdr p -> cr p _3
-  PrimPairP p -> pure1 . EBool . maybe False (const True) $
+  BuiltinPairP p -> pure1 . EBool . maybe False (const True) $
     p ^? #_EPair
-  PrimValues xs -> pure xs
+  BuiltinValues xs -> pure xs
-  PrimList xs -> foldrM pcons ENull xs >>= pure1
+  BuiltinList xs -> foldrM pcons ENull xs >>= pure1
   p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
   where
     pure1 x = pure [x]

src/Gyehoek/CPS/Syntax.hs

@@ -13,7 +13,7 @@ module Gyehoek.CPS.Syntax
   , Kexp(..)
   , ExpF(..)
   , Name(..)
-  , Prim(..)
+  , Builtin(..)
   , Program(..)
   , HoistedProgram(..)
   , Lit(..)
@@ -25,7 +25,7 @@ module Gyehoek.CPS.Syntax
   , pattern Halt
   , pattern Halt1
   , _MkKappa
-  , _ExpPrim
+  , _ExpBuiltin
   , _ExpLetRec
   , _ExpApply
   , _AbsLambda'
@@ -50,7 +50,7 @@ module Gyehoek.CPS.Syntax
   )
   where
 
-import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..))
+import Gyehoek.Scheme.Syntax (Name (..), Builtin(..), builtinDatumIso, Lit(..))
 import Gyehoek.Sexp qualified as S
 import Control.Category
 import Prelude hiding ((.), id)
@@ -163,7 +163,7 @@ pattern ExpJump f xs ktail <- (preview _ExpJump -> Just (f,xs,ktail))
   where ExpJump f xs ktail = review _ExpJump (f,xs,ktail)
 
 data Exp
-  = ExpPrim (Prim Val) Kexp
+  = ExpBuiltin (Builtin Val) Kexp
   | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
   | ExpContinue Val (List Val)
   | ExpIf Val Name Name
@@ -367,7 +367,7 @@ instance S.DatumIso Exp where
         >>> S.onTail S.swap
       prim = S.list $
         S.el (S.decorate S.SynBuiltin >>> S.sym "prim")
-        >>> S.el (primDatumIso id (S.datumIso @Val))
+        >>> S.el (builtinDatumIso id (S.datumIso @Val))
         >>> S.el S.datumIso
 
 instance S.DatumIso Kexp where
@@ -453,7 +453,7 @@ instance Free Kexp where
 
 instance Free Exp where
   freeWithBound' bound = \case
-    ExpPrim p k ->
+    ExpBuiltin p k ->
       (p ^.. folded . #ValVar . filtered (`notElem` bound))
       ++ freeWithBound' bound k
     ExpLetRec bs m ->

src/Gyehoek/Scheme/Expand.hs

@@ -172,15 +172,6 @@ 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})|])
-  _
-
-
-
 {- |
 
 * Examples

src/Gyehoek/Scheme/Expand/Old.hs

@@ -0,0 +1,536 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TypeFamilies #-}
+module Gyehoek.Scheme.Expand.Old
+  (
+  ) where
+
+import Gyehoek.Sexp.Syntax
+import Gyehoek.Sexp qualified as S
+import Gyehoek.Prelude
+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
+import Data.These
+import Data.Zip
+import Prelude hiding (filter, zip, mapMaybe)
+import qualified Data.List.NonEmpty as NE
+import Data.Monoid (Ap(Ap, getAp))
+import Gyehoek.Sexp.Grammar.Base ((:-)(..))
+import Control.Lens.Extras (is)
+import Control.Applicative (Alternative(..))
+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, mapAccumR)
+import Effectful.State.Dynamic
+import Witherable
+import Data.Semigroup (Arg(..))
+import Data.Ord (Down(..))
+import qualified Data.Scientific as Sci
+
+
+data Bind
+  = BindLexical { symbol :: Name, identity :: Natural }
+  | BindGlobal { symbol :: Name }
+  deriving stock (Generic, Eq, Show)
+  deriving anyclass (Hashable)
+
+newtype Scope = MkScope { identity :: Natural }
+  deriving stock (Show, Generic, Eq, Ord)
+  deriving anyclass (Hashable)
+  deriving newtype (Gen)
+
+type ScopeSet = HashSet Scope
+
+data Formals
+  = FormalsFixed (List Name)
+  | FormalsRest (List Name) Name
+  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, e)) (List e)
+  deriving (Show, Generic, Functor, Foldable, Traversable)
+
+data Prim e
+  = PrimLambda (PrimLambda e)
+  | PrimLet (PrimLet e)
+  | PrimIf (PrimIf e)
+  | PrimLetSyntax (PrimLetSyntax e)
+  | PrimSyntaxRules Trans
+  deriving (Show, Generic)
+
+data Key = MkKey Name (HashSet Scope)
+  deriving stock (Show, Generic, Eq)
+  deriving anyclass (Hashable)
+
+
+
+instance S.DatumIso Scope where
+  datumIso = S.with (S.datumIso >>>)
+
+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 -> adorn SynBuiltin (Symbol s) :- 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)
+    >>> 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
+
+
+
+{- |
+
+* Examples
+
+>>> :set -XTemplateHaskellQuotes
+>>> pat = S.makeSx [|| S.fromDatumUnsafe @Pat S.datumIso ||]
+>>> match [] [pat|(x . y)|] [S.sx|(1 2 . 2)|]
+Nothing
+>>> match [] [pat|(x . y)|] [S.sx|(1 . 2)|]
+Just
+...
+>>> match ["=>"] [pat|(x => y)|] [S.sx|(1 => 2)|]
+Just
+...
+>>> match ["=>"] [pat|(x => y)|] [S.sx|(1 -> 2)|]
+Nothing
+-}
+match :: Foldable f
+  => f Text
+  -- ^ Literal keywords
+  -> Pat
+  -> Datum
+  -> Maybe (HashMap Name Datum)
+match kws p = getAp . match' p where
+
+  match' :: Pat -> Datum -> Ap Maybe (HashMap Name Datum)
+  
+  match' PatWildcard _ = pure mempty
+  
+  match' (PatVar x) e
+    | coerce x `elem` kws = case e of
+      Symbol x' | coerce x == x' -> pure mempty
+      _                          -> empty
+    | otherwise = pure $ H.singleton x e
+  
+  match' (PatList ps Nothing Nothing) (List es) = matches ps es
+  
+  match' (PatList ps (Just []) Nothing) (List es) = do
+    let (ps',p) = ps ^?! _Snoc
+    (r,rest) <- fold $ alignWith f ps' es
+    rest' <- rest
+      & fmap (fmap (fmap (:[])) . match' p)
+      & foldr (liftA2 $ H.unionWith (<>)) mempty
+      & fmap (fmap List)
+    pure $ r <> rest'
+    where
+      f (These a b) = (,[]) <$> match' a b
+      f (This a) = empty
+      f (That b) = pure (mempty,[b])
+  
+  match' (PatList ps Nothing (Just p)) (DotList es e) =
+    matches (p:|ps) (NE.cons e es)
+  
+  match' _ _ = _
+  
+  matchPrefix
+    :: (Semialign f, Foldable f)
+    => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum, List Datum)
+  matchPrefix ps es = fold $ alignWith f ps es
+    where
+      f (These a b) = (,[]) <$> match' a b
+      f (This a) = empty
+      f (That b) = pure (mempty,[b])
+  
+  matches
+    :: (Semialign f, Foldable f)
+    => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum)
+  matches ps es = fold $ alignWith matchThese ps es
+  
+  matchThese (These a b) = match' a b
+  matchThese _ = empty
+
+
+
+-- | this hashmap is "curried" since we often want to traverse the
+-- entire set of scopes associated with a given symbol.
+newtype SymTable = MkSymTable
+  { curried :: HashMap Name (HashMap (HashSet Scope) Bind) }
+  deriving (Show, Generic)
+
+type instance Index SymTable = Name
+type instance IxValue SymTable = HashMap (HashSet Scope) Bind
+instance Ixed SymTable where ix j = #curried . ix j
+instance At SymTable where at j = #curried . at j
+
+instance Semigroup SymTable where
+  MkSymTable c1 <> MkSymTable c2 = MkSymTable $ H.unionWith (<>) c1 c2
+
+instance Monoid SymTable where mempty = MkSymTable mempty
+
+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
+
+testExpand :: Datum -> IO (CommandOrDef, SymTable)
+testExpand = runJalmotIO . runExpand (symTableOfEnv env_scheme_base)
+  . expand env_scheme_base mempty
+
+-- | denotations
+data Denot
+  = DenotVar
+  | DenotMacro Trans
+  | DenotPrim Name
+  | DenotSyntax Datum
+  | DenotKeyword 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"
+      ]
+
+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
+
+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
+
+emit :: (Monoid m, State m :> es) => m -> Eff es ()
+emit x = modify (<> x)
+
+binding :: Name -> HashSet Scope -> Bind -> SymTable
+binding sym scopes = MkSymTable . H.singleton sym . H.singleton scopes
+
+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
+  :: 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 @(Eff es) $ ix x
+  case nearest (MkKey x scopes) (H.keys ss) of
+    [] -> err [i|심벌 #{x}는 정의되지 않다|]
+    (_:_:_) -> err [i|심벌 #{x}는 모호하다|]
+    [s] | Just b <- ss ^? ix s
+        , Just d <- g ^? ix b -> pure (b,d)
+        | otherwise -> error "unreachable"
+
+{- | Given a 'Key' and a collection of 'ScopeSet's, filter that
+collection down to the largest subsets of the 'Key'\'s scope set.
+This is our analogue of the lexical scoping rule which chooses the
+"nearest" binding of a variable when shadowing occurs.
+
+  - If no qualifying subsets are found, the name is not in scope.
+  - If one subset is found, we're on the happy path!
+  - If more than one subset is found, we're on the rarest and
+    saddest path: the reference is ambiguous.
+
+* Examples
+
+> (let ((x {A} 123))
+>   (λ (x {A,B})
+>     (let ((y {A,B,C} 456))
+>       x {A,B,C})))
+    
+>>> :seti -XOverloadedLists
+>>> :{
+nearest
+  (MkKey "x" [MkScope 0, MkScope 1, MkScope 2])
+  [ [MkScope 0]
+  , [MkScope 0, MkScope 1] ]
+:}
+-}
+nearest :: (Traversable f, Filterable f) => Key -> f ScopeSet -> List ScopeSet
+nearest (MkKey symbol scopes) =
+  mapMaybe (\x ->
+    if x `HS.isSubsetOf` scopes
+    then Just . Down $ Arg (length x) x
+    else Nothing)
+  -- 나쁨. 안 좋다. 안 좋아하야.
+  >>> Data.Foldable.toList >>> sort
+  >>> foldr (\cases
+    x [] -> [x]
+    x acc@(y:_) -> case x `compare` y of
+      LT -> acc
+      EQ -> x:acc
+      GT -> [x])
+    []
+  >>> fmap (\(Down (Arg _ x)) -> x)
+
+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
+    DenotMacro trans -> expandMacro g scopes trans 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
+
+expandMacro
+  :: (Expand es, Jalmot :> es)
+  => Env -> ScopeSet -> Trans -> Datum -> Eff es CommandOrDef
+expandMacro g scopes trans datum = _
+
+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
+    PrimLetSyntax (MkPrimLetSyntax bs [body]) -> do
+      scopes' <- flip HS.insert scopes <$> gensym
+      (rhss,g') <- (_2 %~ (g<>) . fold) . Prelude.unzip <$> for bs \(x,trans) ->
+        expandAsExp g scopes trans >>= \case
+          ExpSyntaxRules trans' ->
+            (trans',) <$> bindLexical scopes' x (DenotMacro trans')
+          e -> err [i|syntax-rules를 원하는데 이것 받는다: #{e}|]
+      Command <$> (ExpLetSyntax
+        (zip (bs ^.. each . _1) rhss)
+        <$> expandAsExp g' scopes' body
+        )
+    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
+
+
+
+trans_when :: Trans
+trans_when = MkTrans
+  { ellipsis = "..."
+  , keywords = []
+  , rules =
+    [ MkRule
+      (PatList
+        [ PatVar "when"
+        , PatVar "test"
+        , PatVar "body" ]
+        (Just [])
+        Nothing)
+      (TemList
+        [ El $ TemVar "if"
+        , El $ TemVar "test"
+        , El $ TemList
+          [ El $ TemVar "begin"
+          , Ellipsis $ TemVar "body"
+          ]
+          Nothing
+        ]
+        Nothing)
+    ]
+  }
+
+trans_and :: Trans
+trans_and = MkTrans
+  { ellipsis = "..."
+  , keywords = []
+  , rules =
+    [ MkRule
+        (PatList
+          [PatVar "and"]
+          Nothing
+          Nothing)
+        (TemLit (LitBool True))
+    , MkRule
+        (PatList
+          [PatVar "and", PatVar "x"]
+          Nothing
+          Nothing)
+        (TemVar "x")
+    , MkRule
+        (PatList
+          [PatVar "and", PatVar "x", PatVar "y"]
+          (Just [])
+          Nothing)
+        (TemList
+          [ El (TemVar "if")
+          , El (TemVar "x")
+          , El (TemList
+              [ El (TemVar "and")
+              , Ellipsis (TemVar "y")
+              ]
+              Nothing)
+          , El . TemLit . LitBool $ False
+          ]
+          Nothing)
+    ]
+  }

src/Gyehoek/Scheme/Expand/Syntax.hs

@@ -1,9 +0,0 @@
-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

@@ -13,7 +13,7 @@
 {-# LANGUAGE ViewPatterns #-}
 module Gyehoek.Scheme.Syntax
   ( Name(..)
-  , Prim(..)
+  , Builtin(..)
   , Lit(..)
   , Def(..)
   , Exp(..)
@@ -25,7 +25,7 @@ module Gyehoek.Scheme.Syntax
   , Pat(..)
   , Tem(..)
   , El(..)
-  , primDatumIso
+  , builtinDatumIso
   , free
   , subst
   , getName
@@ -74,36 +74,36 @@ instance Prefixed Name where
 getName :: Name -> Text
 getName (MkName x) = x
 
-data Prim e
+data Builtin e
-  = PrimAdd e e
+  = BuiltinAdd e e
-  | PrimSub e e
+  | BuiltinSub e e
-  | PrimMul e e
+  | BuiltinMul e e
-  | PrimDiv e e
+  | BuiltinDiv e e
-  | PrimCons e e
+  | BuiltinCons e e
-  | PrimCar e
+  | BuiltinCar e
-  | PrimCdr e
+  | BuiltinCdr e
-  | PrimImmediateP e
+  | BuiltinImmediateP e
-  | PrimConsP e
+  | BuiltinConsP e
-  | PrimIntegerP e
+  | BuiltinIntegerP e
-  | PrimWrite e
+  | BuiltinWrite e
-  | PrimZeroP e
+  | BuiltinZeroP e
-  | PrimNewline
+  | BuiltinNewline
-  | PrimMakeClosure { code :: e, env :: List e }
+  | BuiltinMakeClosure { code :: e, env :: List e }
-  | PrimMakeSharedClosure { codes :: List e, env :: List e }
+  | BuiltinMakeSharedClosure { codes :: List e, env :: List e }
-  | PrimGetEnv
+  | BuiltinGetEnv
-  | PrimEnv
+  | BuiltinEnv
-  | PrimEnvRef Int
+  | BuiltinEnvRef Int
-  | PrimCallCC e
+  | BuiltinCallCC e
-  | PrimCaptureCC
+  | BuiltinCaptureCC
-  | PrimInvokeCC e (List e)
+  | BuiltinInvokeCC e (List e)
-  | PrimValues (List e)
+  | BuiltinValues (List e)
-  | PrimCallWithValues e e
+  | BuiltinCallWithValues e e
-  | PrimPairP e
+  | BuiltinPairP e
-  | PrimList (List e)
+  | BuiltinList (List e)
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
 
-instance Each (Prim e) (Prim e') e e'
+instance Each (Builtin e) (Builtin e') e e'
 
 data Lit
   = LitInt Int
@@ -122,7 +122,7 @@ data Exp
   = ExpLet (List (Name, Exp)) Exp
   | ExpLetSyntax (List (Name, Trans)) Exp
   | ExpLetRec (List (Name, Exp)) Exp
-  | ExpPrim (Prim Exp)
+  | ExpBuiltin (Builtin Exp)
   | ExpBegin (NonEmpty Exp)
   | ExpIf Exp Exp (Maybe Exp)
   | ExpLit Lit
@@ -245,10 +245,10 @@ instance DatumIso Name where
     >>> S.symbol
     >>> S.iso coerce coerce
 
-primDatumIso
+builtinDatumIso
   :: (Text -> Text)
-  -> S.DatumGrammar a -> S.DatumGrammar (Prim a)
+  -> S.DatumGrammar a -> S.DatumGrammar (Builtin a)
-primDatumIso namefn a = S.match
+builtinDatumIso namefn a = S.match
     $ S.With (. ht2 "+")
     $ S.With (. ht2 "-")
     $ S.With (. ht2 "*")
@@ -285,8 +285,8 @@ primDatumIso namefn a = S.match
       ht1' s = S.headTagged1' (namefn s) a a
       ht0' s = S.headTagged0' (namefn s) a
 
-instance DatumIso a => DatumIso (Prim a) where
+instance DatumIso a => DatumIso (Builtin a) where
-  datumIso = primDatumIso id S.datumIso
+  datumIso = builtinDatumIso id S.datumIso
 
 instance DatumIso Lit where
   datumIso = S.match