tools-yj (empty) → 0.1.0.19

raw patch · 18 files changed

+363/−0 lines, 18 filesdep +basedep +containersdep +data-defaultsetup-changed

Dependencies added: base, containers, data-default, mono-traversable, stm, text, tools-yj

Files

• CHANGELOG.md +11/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• src/Control/Concurrent/STM/ToolsYj.hs +16/−0
• src/Data/Bits/ToolsYj.hs +8/−0
• src/Data/Bool/ToolsYj.hs +14/−0
• src/Data/Either/ToolsYj.hs +12/−0
• src/Data/Function/ToolsYj.hs +15/−0
• src/Data/IORef/ToolsYj.hs +18/−0
• src/Data/List/ToolsYj.hs +38/−0
• src/Data/Maybe/ToolsYj.hs +28/−0
• src/Data/Ord/ToolsYj.hs +8/−0
• src/Data/Sequences/ToolsYj.hs +27/−0
• src/Data/Text/ToolsYj.hs +26/−0
• src/Data/Tuple/ToolsYj.hs +31/−0
• test/Spec.hs +2/−0
• tools-yj.cabal +76/−0

@@ -0,0 +1,11 @@+# Changelog for `try-tools-yj`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD

@@ -0,0 +1,30 @@+Copyright Yoshikuni Jujo (c) 2023++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Yoshikuni Jujo nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,1 @@+# tools-yj

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Concurrent.STM.ToolsYj (newDefaultTVar, readModifyTVar, checkFlag) where++import Control.Concurrent.STM+import Data.Default+import Data.Bool++newDefaultTVar :: Default a => STM (TVar a)+newDefaultTVar = newTVar def++readModifyTVar :: TVar a -> (a -> a) -> STM a+readModifyTVar v f = readTVar v <* modifyTVar v f++checkFlag :: TVar Bool -> STM Bool+checkFlag flg = readTVar flg >>= bool (pure False) (True <$ writeTVar flg False)

@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.Bits.ToolsYj (checkBits) where++import Data.Bits++checkBits :: Bits bs => bs -> bs -> Bool+checkBits wnt = (== wnt) . (.&. wnt)

@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.Bool.ToolsYj (onlyIf, errorIf, errorIfNot) where++import Data.Bool++onlyIf :: (a -> Bool) -> a -> Maybe a+onlyIf p x = bool Nothing (Just x) (p x)++errorIf :: String -> Bool -> IO ()+errorIf msg = bool (pure ()) (error msg)++errorIfNot :: String -> Bool -> IO ()+errorIfNot msg = bool (error msg) (pure ())

@@ -0,0 +1,12 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.Either.ToolsYj (forceRight, forceRight') where++import Control.Exception++forceRight :: Exception e => Either e a -> a+forceRight = \case Left e -> throw e; Right x -> x++forceRight' :: Either String a -> a+forceRight' = forceRight . either (Left . ErrorCall) Right

@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.Function.ToolsYj (const2, const3, const4, const5) where++const2 :: a -> b -> c -> a+const2 = const . const++const3 :: a -> b -> c -> d -> a+const3 = const . const2++const4 :: a -> b -> c -> d -> e -> a+const4 = const . const3++const5 :: a -> b -> c -> d -> e -> f -> a+const5 = const . const4

@@ -0,0 +1,18 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.IORef.ToolsYj (newDefaultIORef, checkFlag) where++import Data.Default+import Data.Bool+import Data.IORef++newDefaultIORef :: Default a => IO (IORef a)+newDefaultIORef = newIORef def++checkFlag :: IORef Bool -> IO Bool+checkFlag flg =+	readIORef flg >>= bool (pure False) (True <$ writeIORef flg False)

@@ -0,0 +1,38 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.List.ToolsYj (+	list, list', replicateWithI, replicateMWithI,+	elemAll, elemNotAll, findDefault, listToTuple4+	) where++import Data.Maybe+import Data.List ((\\), find)+import Data.List.NonEmpty (NonEmpty(..))++list :: b -> (a -> [a] -> b) -> [a] -> b+list n c = \case [] -> n; x : xs -> c x xs++list' :: b -> (NonEmpty a -> b) -> [a] -> b+list' n c = \case [] -> n; x : xs -> c $ x :| xs++replicateWithI :: Int -> (Int -> a) -> [a]+replicateWithI n f = go 0+	where go i | i < n = f i : go (i + 1) | otherwise = []++replicateMWithI :: Applicative m => Int -> (Int -> m a) -> m [a]+replicateMWithI n f = go 0+	where go i | i < n = (:) <$> f i <*> go (i + 1) | otherwise = pure []++elemAll :: Eq a => [a] -> [a] -> Bool+elemAll es = null . (es \\)++elemNotAll :: Eq a => [a] -> [a] -> Bool+elemNotAll es = not . elemAll es++findDefault :: a -> (a -> Bool) -> [a] -> a+findDefault d p = fromMaybe d . find p++listToTuple4 :: [a] -> (a, a, a, a)+listToTuple4 [r, g, b, a] = (r, g, b, a)+listToTuple4 _ = error "The length of the list is not 4"

@@ -0,0 +1,28 @@+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.Maybe.ToolsYj (+	forceJust, forceJust', orErrorIO, findMaybe, findMaybeM ) where++import Control.Exception++forceJust :: Exception e => e -> Maybe a -> a+forceJust e = maybe (throw e) id++forceJust' :: String -> Maybe a -> a+forceJust' = forceJust . ErrorCall++orErrorIO :: String -> Maybe a -> IO a+orErrorIO msg = maybe (error msg) pure++findMaybe :: (a -> Maybe b) -> [a] -> Maybe (a, b)+findMaybe prd = \case+	[] -> Nothing+	p : ps -> ($ prd p) \case+		Nothing -> findMaybe prd ps; Just x -> Just (p, x)++findMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe (a, b))+findMaybeM prd = \case+	[] -> pure Nothing+	p : ps -> prd p >>= \case+		Nothing -> findMaybeM prd ps; Just x -> pure $ Just (p, x)

@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.Ord.ToolsYj (clamp, Min, Max) where++clamp :: Ord a => Min a -> Max a -> a -> a+clamp mn mx x | x < mn = mn | x < mx = x | otherwise = mx++type Min a = a; type Max a = a

@@ -0,0 +1,27 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.Sequences.ToolsYj (indexing) where++import Data.MonoTraversable qualified as Mono+import Data.Sequences qualified as Seq+import Data.Map qualified as M++indexing :: (+	Mono.MonoFoldable seq, Mono.Element seq ~ Mono.Element seq',+	Seq.IsSequence seq', Ord (Mono.Element seq),+	Seq.IsSequence seqi, Enum (Mono.Element seqi) ) => seq -> (seq', seqi)+indexing (Mono.otoList -> xs) = let+	(xs', is) = indexingGo 0 M.empty xs in+	(Seq.fromList $ M.elems xs', Seq.fromList $ toEnum <$> is)++indexingGo :: Ord a => Int -> M.Map a Int -> [a] -> (M.Map Int a, [Int])+indexingGo _ _ [] = (M.empty, [])+indexingGo idx rvdct (x : xs) = case M.lookup x rvdct of+	Nothing -> let+		(dct, is) = indexingGo (idx + 1) (M.insert x idx rvdct) xs in+		(M.insert idx x dct, idx : is)+	Just i -> let (dct, is) = indexingGo idx rvdct xs in (dct, i : is)

@@ -0,0 +1,26 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.Text.ToolsYj (cstrToText) where++import Foreign.Ptr+import Foreign.Storable+import Foreign.C.String+import Data.Text qualified as Txt+import Data.Text.Foreign qualified as Txt++cstrToText :: CString -> IO Txt.Text+cstrToText cs = Txt.peekCStringLen =<< cstringToCStringLen cs++cstringLength :: CString -> IO Int+cstringLength pc = do+	c <- peek pc+	case c of+		0 -> pure 0+		_ -> (+ 1) <$> cstringLength (pc `plusPtr` 1)++cstringToCStringLen :: CString -> IO CStringLen+cstringToCStringLen cs = (cs ,) <$> cstringLength cs

@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.Tuple.ToolsYj (+	uncurryDup,+	mapTup3, appTup3, mapTup3M, appTup3M, mapTup3M_, appTup3M_+	) where++import Control.Monad++uncurryDup :: (a -> b -> c -> d) -> ((a, b), c) -> d+uncurryDup = uncurry . uncurry++mapTup3 :: (a -> b) -> (a, a, a) -> (b, b, b)+mapTup3 f = appTup3 f f f++appTup3 :: (a -> b) -> (c -> d) -> (e -> f) -> (a, c, e) -> (b, d, f)+appTup3 f g h (x, y, z) = (f x, g y, h z)++mapTup3M :: Applicative m => (a -> m b) -> (a, a, a) -> m (b, b, b)+mapTup3M f = appTup3M f f f++appTup3M :: Applicative m =>+	(a -> m b) -> (c -> m d) -> (e -> m f) -> (a, c, e) -> m (b, d, f)+appTup3M f g h (x, y, z) = (,,) <$> f x <*> g y <*> h z++mapTup3M_ :: Applicative m => (a -> m b) -> (a, a, a) -> m ()+mapTup3M_ f = void . mapTup3M f++appTup3M_ :: Applicative m =>+	(a -> m b) -> (c -> m d) -> (e -> m f) -> (a, c, e) -> m ()+appTup3M_ f g h = void . appTup3M f g h

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"

@@ -0,0 +1,76 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           tools-yj+version:        0.1.0.19+synopsis:       Tribial tools+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/tools-yj#readme>+category:       Tools+homepage:       https://github.com/YoshikuniJujo/tools-yj#readme+bug-reports:    https://github.com/YoshikuniJujo/tools-yj/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      Copyright (c) 2023 Yoshikuni Jujo+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-doc-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/tools-yj++library+  exposed-modules:+      Control.Concurrent.STM.ToolsYj+      Data.Bits.ToolsYj+      Data.Bool.ToolsYj+      Data.Either.ToolsYj+      Data.Function.ToolsYj+      Data.IORef.ToolsYj+      Data.List.ToolsYj+      Data.Maybe.ToolsYj+      Data.Ord.ToolsYj+      Data.Sequences.ToolsYj+      Data.Text.ToolsYj+      Data.Tuple.ToolsYj+  other-modules:+      Paths_tools_yj+  autogen-modules:+      Paths_tools_yj+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , containers <1+    , data-default <1+    , mono-traversable <2+    , stm <3+    , text <3+  default-language: Haskell2010++test-suite tools-yj-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_tools_yj+  autogen-modules:+      Paths_tools_yj+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers <1+    , data-default <1+    , mono-traversable <2+    , stm <3+    , text <3+    , tools-yj+  default-language: Haskell2010