From a48676b21736836d2cc2d50791c3e70d851f3324 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Sun, 2 Feb 2025 00:29:53 +0300 Subject: [PATCH] suckless, some functions --- .../Data/Config/Suckless/Script/Internal.hs | 187 +++++++++++++++++- .../lib/Data/Config/Suckless/Syntax.hs | 3 + 2 files changed, 188 insertions(+), 2 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 a5c13ce0..d895b60d 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -35,6 +35,7 @@ import Data.HashSet (HashSet) import Data.HashSet qualified as HS import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM +import Data.Map qualified as Map import Data.Kind import Data.List (isPrefixOf) import Data.List qualified as List @@ -204,6 +205,18 @@ blobLike = \case pattern BlobLike :: forall {c} . ByteString -> Syntax c pattern BlobLike s <- (blobLike -> Just s) +toSortable :: Syntax c -> Either Double Text +toSortable = \case + LitIntVal n -> Left (fromIntegral n) + LitScientificVal n -> Left (realToFrac n) + LitBoolVal False -> Left 0 + LitBoolVal True -> Left 1 + LitStrVal s -> Right s + SymbolVal (Id s) -> Right s + ListVal es -> Left (fromIntegral (length es)) + OpaqueValue box -> Left 0 + _ -> Left 0 + class Display a where display :: MonadIO m => a -> m () @@ -798,7 +811,9 @@ instance IsContext c => MkSyntax c IniConfig where mkList (globals <> sections) -internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m () +internalEntries :: forall c m . ( IsContext c + , Exception (BadFormException c) + , MonadUnliftIO m) => MakeDictM c m () internalEntries = do entry $ bindValue "false" (mkBool False) @@ -940,10 +955,12 @@ internalEntries = do entry $ bindMatch "last" $ \case [ ListVal es ] -> pure (lastDef nil es) + [ StringLike es ] -> pure $ maybe nil (mkSym . List.singleton) (lastMay es) _ -> throwIO (TypeCheckError @C nil) entry $ bindMatch "head" $ \case [ ListVal es ] -> pure (headDef nil es) + [ StringLike es ] -> pure $ maybe nil (mkSym . List.singleton) (headMay es) _ -> throwIO (TypeCheckError @C nil) entry $ bindMatch "cons" $ \case @@ -974,16 +991,99 @@ internalEntries = do [ListVal es] -> pure $ mkList (tail es) _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "filter" $ \case + [pred, ListVal xs] -> do + filtered <- flip filterM xs $ \x -> do + res <- apply_ pred [x] + case res of + LitBoolVal True -> pure True + _ -> pure False + + pure $ mkList filtered + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "group-by" $ \case + [cmp, ListVal es] -> do + let groupByM _ [] = pure [] + groupByM eq (x:xs) = do + (same, rest) <- partitionM (eq x) xs + groups <- groupByM eq rest + pure ((x:same) : groups) + + let eqFunc a b = do + result <- apply_ cmp [a, b] + pure $ case result of + LitBoolVal v -> v + _ -> False -- Если не bool, считаем, что не равны + + grouped <- groupByM eqFunc es + pure $ mkList [mkList group | group <- grouped] + + _ -> throwIO (BadFormException @c nil) + + + entry $ bindMatch "sort-with" $ \case + [cmp, ListVal es] -> do + let cmpFunc a b = do + result <- apply_ cmp [a, b] + pure $ case result of + LitBoolVal v -> v + _ -> False -- Если не bool, считаем `x < y` ложным + + sorted <- sortByM cmpFunc es + pure $ mkList sorted + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "sort-by" $ \case + [what, ListVal es] -> do + sorted <- forM es \e -> do + key <- apply_ what [e] + pure (key, e) + + pure $ mkList [e | (_, e) <- List.sortOn (toSortable . fst) sorted] + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "flatten" $ \case + [ListVal es] -> pure $ mkList (concatMap flattenList es) + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "reverse" $ \case + [ListVal es] -> pure $ mkList (List.reverse es) + [LitStrVal s] -> pure $ mkStr (Text.reverse s) + [SymbolVal (Id s)] -> pure $ mkSym (Text.reverse s) + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "nub" $ \case + [ ListVal es ] -> pure $ mkList $ List.nub es + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "zip" $ \case + [ ListVal a, ListVal b ] -> pure $ mkList (zipWith (\x y -> mkList [x,y]) a b) + _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "take" $ \case [ LitIntVal n, ListVal es ] -> pure $ mkList $ take (fromIntegral n) es + [ LitIntVal n, StringLike es ] -> pure $ mkStr $ take (fromIntegral n) es _ -> throwIO (BadFormException @c nil) entry $ bindMatch "drop" $ \case [ LitIntVal n, ListVal es ] -> pure $ mkList $ drop (fromIntegral n) es + [ LitIntVal n, StringLike es ] -> pure $ mkStr $ drop (fromIntegral n) es _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "nth" $ \case - [ LitIntVal i, ListVal es ] -> pure $ atDef nil es (fromIntegral i) + [LitIntVal i, ListVal es] -> do + let idx = if i < 0 then length es + fromIntegral i else fromIntegral i + pure $ atDef nil es idx + + [LitIntVal i, StringLike es] -> do + let idx = if i < 0 then length es + fromIntegral i else fromIntegral i + pure $ maybe nil (mkSym . List.singleton) $ atMay es idx + _ -> throwIO (BadFormException @c nil) entry $ bindMatch "assoc" $ \case @@ -1010,6 +1110,14 @@ internalEntries = do [ TextLike x ] -> pure $ mkList [ mkSym y | y <- Text.lines x ] _ -> pure nil + entry $ bindMatch "mod" $ \case + [LitIntVal a, LitIntVal b] | b /= 0 -> pure $ mkInt (a `mod` b) + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "%" $ \case + [LitIntVal a, LitIntVal b] | b /= 0 -> pure $ mkInt (a `mod` b) + _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "sum" $ \case [ ListVal es ] -> do let v = flip mapMaybe es \case @@ -1245,6 +1353,27 @@ internalEntries = do pure $ if a == b then mkBool True else mkBool False _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "str" $ \case + [] -> pure $ mkStr "" + [x] -> pure $ mkStr (show $ pretty x) + xs -> pure $ mkStr $ mconcat [ show (pretty e) | e <- xs ] + + entry $ bindMatch "le?" $ \case + [a, b] -> pure $ mkBool (compareSyn a b == LT) + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "gt?" $ \case + [a, b] -> pure $ mkBool (compareSyn a b == GT) + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "leq?" $ \case + [a, b] -> pure $ mkBool (compareSyn a b /= GT) -- LT или EQ + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "gte?" $ \case + [a, b] -> pure $ mkBool (compareSyn a b /= LT) -- GT или EQ + _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "length" $ \case [ListVal es] -> pure $ mkInt (length es) [StringLike es] -> pure $ mkInt (length es) @@ -1410,3 +1539,57 @@ matchOne what = \case e@(ListVal xs) -> or [ Text.isInfixOf what s | TextLike s <- xs ] _ -> False +flattenList :: IsContext c => Syntax c -> [Syntax c] +flattenList (ListVal xs) = concatMap flattenList xs +flattenList x = [x] + +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = pure ([], []) +partitionM p (x:xs) = do + (yes, no) <- partitionM p xs + b <- p x + pure $ if b then (x:yes, no) else (yes, x:no) + +groupByM :: Monad m => (a -> a -> m Bool) -> [a] -> m [[a]] +groupByM _ [] = pure [] +groupByM eq (x:xs) = do + (same, rest) <- partitionM (eq x) xs + groups <- groupByM eq rest + pure ((x:same) : groups) + +toOrdering :: Bool -> Ordering +toOrdering True = LT -- Если `cmp x y` → True, то `x < y` +toOrdering False = GT -- Иначе `x > y` + +sortByM :: Monad m => (a -> a -> m Bool) -> [a] -> m [a] +sortByM cmp xs = do + let indexed = zip xs [0..] + + keyVals <- mapM (\(a, i) -> do + k <- mapM (\b -> cmp a b) xs + pure (sum (map fromEnum k), i, a)) + indexed + + let sorted = List.sortOn (\(key, idx, _) -> (key, idx)) keyVals + + pure $ map (\(_, _, val) -> val) sorted + +compareSyn :: Syntax c -> Syntax c -> Ordering +compareSyn (LitIntVal a) (LitIntVal b) = compare a b +compareSyn (LitScientificVal a) (LitScientificVal b) = compare a b +compareSyn (LitIntVal a) (LitScientificVal b) = compare (fromIntegral a) b +compareSyn (LitScientificVal a) (LitIntVal b) = compare a (fromIntegral b) +compareSyn (TextLike a) (TextLike b) = compare a b +compareSyn (ListVal a) (ListVal b) = compareLists a b +compareSyn _ _ = error "type check error" + +-- Лексикографическое сравнение списков +compareLists :: [Syntax c] -> [Syntax c] -> Ordering +compareLists [] [] = EQ -- Оба пустые → равно +compareLists [] _ = LT -- Пустой список всегда "меньше" непустого +compareLists _ [] = GT -- Непустой список всегда "больше" пустого +compareLists (x:xs) (y:ys) = + case compareSyn x y of + EQ -> compareLists xs ys -- Если элементы равны, сравниваем дальше + ord -> ord + diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs index 89ed567f..98235a56 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs @@ -387,3 +387,6 @@ instance IsContext c => MkSyntax c Value where mkSyntax (Object kv) = mkList [ mkList [mkSym (Aeson.toText k), mkSyntax v] | (k,v) <- Aeson.toList kv] + + +