diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index 7f27468d..591ea1f5 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/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 - _ -> Nothing + (SymbolVal x) -> Just x + _ -> 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 - - 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 + applyLambda decl body args 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