From 816786fd5bf4fe33e8b6fff2dd343f8181d8d50d Mon Sep 17 00:00:00 2001 From: voidlizard Date: Fri, 24 Jan 2025 14:11:18 +0300 Subject: [PATCH] wip --- .../Data/Config/Suckless/Script/Internal.hs | 85 ++++++++++++------- 1 file changed, 54 insertions(+), 31 deletions(-) diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index a268de4d..f33f9610 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -11,6 +11,7 @@ module Data.Config.Suckless.Script.Internal import Data.Config.Suckless import Data.Config.Suckless.Almost.RPC +import Data.Traversable import Control.Applicative import Control.Monad import Control.Monad.Identity @@ -503,13 +504,11 @@ apply_ :: forall c m . ( IsContext c apply_ s args = case s of ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> apply n args - SymbolVal "quot" -> pure $ mkList args - SymbolVal "quote" -> pure $ mkList args SymbolVal "quasiquot" -> mkList <$> mapM (evalQQ mempty) args SymbolVal "quasiquote" -> mkList <$> mapM (evalQQ mempty) args SymbolVal what -> apply what args Lambda d body -> applyLambda d body args - e -> throwIO $ NotLambda e + e -> throwIO $ NotLambda e apply :: forall c m . ( IsContext c , MonadUnliftIO m @@ -519,8 +518,9 @@ apply :: forall c m . ( IsContext c -> [Syntax c] -> RunM c m (Syntax c) -apply "quot" args = do - pure $ mkList args +apply "quot" e = case e of + [ x ] -> pure x + _ -> throwIO $ BadFormException @c nil apply "quasiquot" args = do mkList <$> mapM (evalQQ mempty) args @@ -718,7 +718,8 @@ eval' dict0 syn = handle (handleForm syn) $ do e@Literal{} -> pure e - e -> throwIO $ NotLambda @c e + e -> do + throwIO $ NotLambda @c e where handleForm syn = \case @@ -797,10 +798,10 @@ fixContext = go Literal _ l -> Literal noContext l OpaqueValue box -> OpaqueValue box --- quotList :: forall c . IsContext c => Syntax c -> Syntax c --- quotList = \case --- ListVal (x:xs) | x /= mkSym "quot" -> mkList (mkSym "quot" : x : xs) --- e -> e +fixList :: forall c . IsContext c => Syntax c -> Syntax c +fixList = \case + (ListVal es) -> mkList ( mkSym "list" : es ) + e -> e fmt :: Syntax c -> Doc ann fmt = \case @@ -844,6 +845,13 @@ internalEntries = do xs -> do pure $ mkStr ( show $ hcat (fmap fmt xs) ) + entry $ bindMatch "join" $ \case + [ x, ListVal es ] -> do + let xs = List.intersperse x es + pure $ mkStr ( show $ hcat (fmap fmt xs) ) + + _ -> throwIO (BadFormException @C nil) + brief "creates a list of elements" $ args [arg "..." "..."] $ returns "list" "" @@ -889,16 +897,12 @@ internalEntries = do let wat = mkList [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ] pure $ wat - entry $ bindMatch "iterate" $ nil_ $ \syn -> do - case syn of - [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do - mapM_ (apply @c fn . List.singleton) rs + entry $ bindMatch "iterate" $ nil_ $ \case + [ what, ListVal es ] -> do + mapM_ (apply_ what . List.singleton) es - [Lambda decl body, ListVal args] -> do - mapM_ (applyLambda decl body . List.singleton) args - - _ -> do - throwIO (BadFormException @C nil) + _ -> do + throwIO (BadFormException @C nil) entry $ bindMatch "repeat" $ nil_ $ \case [LitIntVal n, Lambda [] b] -> do @@ -927,17 +931,11 @@ internalEntries = do [ LitIntVal n ] -> pure (mkInt (succ n)) _ -> throwIO (TypeCheckError @C nil) - entry $ bindMatch "map" $ \syn -> do - case syn of - [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do - mapM (apply @c fn . List.singleton) rs - <&> mkList + entry $ bindMatch "map" $ \case + [ what, ListVal es ] -> do + mkList <$> mapM (apply_ what . List.singleton) es - [Lambda decl body, ListVal args] -> do - mapM (applyLambda decl body . List.singleton) args - <&> mkList - - _ -> do + _ -> do throwIO (BadFormException @C nil) entry $ bindMatch "quot" $ \case @@ -950,6 +948,10 @@ internalEntries = do _ -> do throwIO (BadFormException @C nil) + entry $ bindMatch "last" $ \case + [ ListVal es ] -> pure (lastDef nil es) + _ -> throwIO (TypeCheckError @C nil) + entry $ bindMatch "head" $ \case [ ListVal es ] -> pure (head es) _ -> throwIO (TypeCheckError @C nil) @@ -968,6 +970,14 @@ internalEntries = do [ListVal es] -> pure $ mkList (tail es) _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "take" $ \case + [ LitIntVal n, ListVal es ] -> pure $ mkList $ take (fromIntegral n) es + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "drop" $ \case + [ LitIntVal n, ListVal es ] -> pure $ mkList $ drop (fromIntegral n) es + _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "nth" $ \case [ LitIntVal i, ListVal es ] -> pure $ atDef nil es (fromIntegral i) _ -> throwIO (BadFormException @c nil) @@ -976,6 +986,19 @@ internalEntries = do [k, ListVal es ] -> pure $ headDef nil [ r | r@(ListVal (w:_)) <- es, k == w ] _ -> throwIO (BadFormException @c nil) + --TODO: integral sum + + entry $ bindMatch "sum" $ \case + [ ListVal es ] -> do + let v = flip mapMaybe es \case + LitIntVal n -> Just $ realToFrac n + LitScientificVal n -> Just $ realToFrac @_ @Double n + _ -> Nothing + + pure $ mkDouble $ sum v + + _ -> pure $ mkDouble 0 + entry $ bindMatch "assoc:nth" $ \case [LitIntVal i, k, ListVal es ] -> do pure $ headDef nil [ r | r@(ListVal ys) <- es, atMay ys (fromIntegral i) == Just k ] @@ -1288,10 +1311,10 @@ internalEntries = do brief "calls external process" $ entry $ bindMatch "call:proc" \case [StringLike what] -> lift do - callProc what mempty mempty <&> mkList @c . fmap (mkForm "quot" . List.singleton . fixContext) + callProc what mempty mempty <&> mkList @c . fmap (fixList . fixContext) StringLikeList (x:xs) -> lift do - callProc x xs mempty <&> mkList @c . fmap (mkForm "quot" . List.singleton . fixContext) + callProc x xs mempty <&> mkList @c . fmap (fixList . fixContext) _ -> throwIO (BadFormException @c nil)