wip, lambdas

hbs2-cli/lib/HBS2/CLI/Run/Internal.hs

@@ -120,19 +120,19 @@ stringLike = \case
 stringLikeList :: [Syntax c] -> [String]
 stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
 
-pattern Lambda :: forall {c}. [Syntax c] -> Syntax c -> Syntax c
+pattern Lambda :: forall {c}. [Id] -> Syntax c -> Syntax c
 pattern Lambda a e <- ListVal [SymbolVal "lambda", LambdaArgs a, e]
 
-pattern LambdaArgs :: [Syntax c] -> Syntax c
+pattern LambdaArgs :: [Id] -> Syntax c
 pattern LambdaArgs a <- (lambdaArgList -> Just a)
 
-lambdaArgList :: Syntax c -> Maybe [Syntax c]
+lambdaArgList :: Syntax c -> Maybe [Id]
 
 lambdaArgList (ListVal a) = sequence argz
   where
     argz = flip fmap a \case
-      x@(SymbolVal{}) -> Just x
+      (SymbolVal x) -> Just x
-      _               -> Nothing
+      _             -> Nothing
 
 lambdaArgList _ = Nothing
 
@@ -247,6 +247,32 @@ splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
 
     emit = S.yield . reverse
 
+applyLambda :: forall c m . ( IsContext c
+                            , MonadUnliftIO m
+                            , Exception (BadFormException c)
+                            )
+            => [Id]
+            -> Syntax c
+            -> [Syntax c]
+            -> RunM c m (Syntax c)
+applyLambda decl body args = do
+
+  when (length decl /= length args) do
+    throwIO (ArgsMismatch @c nil)
+
+  ev <- mapM runExpr args
+  tv <- ask
+  d0 <- readTVarIO tv
+
+  forM_ (zip decl ev) $ \(n,v) -> do
+    bind n v
+
+  e <- runExpr body
+
+  atomically $ writeTVar tv d0
+  pure e
+
+
 apply :: forall c m . ( IsContext c
                       , MonadUnliftIO m
                       , Exception (BadFormException c)
@@ -257,11 +283,38 @@ apply :: forall c m . ( IsContext c
 apply name args' = do
   -- notice $ red "APPLY" <+> pretty name
   what <- ask >>=  readTVarIO <&> HM.lookup name . fromDict
+
   case bindAction <$> what of
     Just (BindLambda e) -> mapM runExpr args' >>= e
-    Just (BindValue v)  -> throwIO (NotLambda name)
+
+    Just (BindValue (Lambda argz body) )  -> do
+      applyLambda argz body args'
+
+    Just (BindValue _) -> do
+      throwIO (NotLambda name)
+
     Nothing -> throwIO (NameNotBound name)
 
+bind :: forall c m . ( IsContext c
+                     , MonadUnliftIO m
+                     , Exception (BadFormException c)
+                     )
+     => Id
+     -> Syntax c
+     -> RunM c m ()
+bind name expr = do
+  t <- ask
+
+  what <- case expr of
+           ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> do
+             Dict m <- readTVarIO t
+             HM.lookup n m & maybe (throwIO (NameNotBound n)) pure
+
+           e -> pure $ Bind (BindValue e) "" ""
+
+  atomically do
+    modifyTVar t (Dict . HM.insert name what . fromDict)
+
 runExpr :: forall c m . ( IsContext c
                         , MonadUnliftIO m
                         , Exception (BadFormException c)
@@ -281,29 +334,19 @@ runExpr syn = handle (handleForm syn) $ do
       ListVal [SymbolVal "lambda", arglist, body] -> do
         pure $ mkForm @c "lambda" [ arglist, body ]
 
+      ListVal [SymbolVal "define", SymbolVal what, e] -> do
+        ev <- runExpr e
+        bind what ev>> pure nil
+
+      ListVal [SymbolVal "define", LambdaArgs (name : args), e] -> do
+        bind name ( mkForm @c  "lambda" [ mkList [ mkSym s | s <- args], e ] )
+        pure nil
 
       ListVal (SymbolVal "begin" : what) -> do
         evalTop what
 
       lc@(ListVal (Lambda decl body : args))  -> do
-
+        applyLambda decl body args
-        when (length decl /= length args) do
-          throwIO (ArgsMismatch lc)
-
-        ev <- mapM runExpr args
-        tv <- ask
-        d0 <- readTVarIO tv
-        atomically do
-          forM_ (zip [ x | SymbolVal x <- decl ] ev) $ \(n,v) -> do
-            let what = case v of
-                        Lambda a b -> Bind (BindLambda (error "CALLIN FUCKING LAMBDA") ) "" ""
-                        x -> Bind (BindValue x) "runtime-value" ""
-            modifyTVar tv (Dict . HM.insert n what . fromDict)
-
-        e <- runExpr body
-
-        atomically $ writeTVar tv d0
-        pure e
 
       ListVal (SymbolVal name : args') -> do
         apply name args'
@@ -317,7 +360,7 @@ runExpr syn = handle (handleForm syn) $ do
 
         case what of
           BindValue e  -> pure e
-          BindLambda e -> pure $ mkForm "lambda" [mkSym name, mkSym "..."]
+          BindLambda e -> pure $ mkForm "builtin:lambda" [mkSym name]
 
       e@(SymbolVal name) | not (HM.member name dict) -> do
         pure e
@@ -365,14 +408,6 @@ nil = List noContext []
 nil_ :: (IsContext c, MonadIO m) =>  (a -> RunM c m b) -> a -> RunM c m (Syntax c)
 nil_ m w = m w >> pure (List noContext [])
 
-bind :: (MonadUnliftIO m, IsContext c) => Id -> Syntax c -> RunM c m (Syntax c)
-bind name expr = do
-  tv <- ask -- >>=  readTVarIO
-  atomically do
-    w@(Dict x) <- readTVar tv
-    writeTVar tv w
-  pure nil
-
 internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
 internalEntries = do
     entry $ bindMatch "concat" $ \syn -> do