diff --git a/ClassyPrelude.hs b/ClassyPrelude.hs --- a/ClassyPrelude.hs +++ b/ClassyPrelude.hs @@ -24,12 +24,17 @@ , traceShowId , traceShowM , assert + -- ** Time (since 0.6.1) + , module Data.Time + , defaultTimeLocale -- * Poly hierarchy , module Data.Foldable , module Data.Traversable -- * Mono hierarchy , module Data.MonoTraversable , module Data.Sequences + , module Data.Sequences.Lazy + , module Data.Textual.Encoding , module Data.Containers -- * I\/O , Handle @@ -62,10 +67,11 @@ , zip, zip3, zip4, zip5, zip6, zip7 , unzip, unzip3, unzip4, unzip5, unzip6, unzip7 , zipWith, zipWith3, zipWith4, zipWith5, zipWith6, zipWith7 - {- - , nub - , nubBy - -} + + , hashNub + , ordNub + , ordNubBy + , sortWith , compareLength , sum @@ -80,6 +86,9 @@ , Show (..) , tshow , tlshow + -- *** Case conversion + , charToLower + , charToUpper -- ** IO , IOData (..) , print @@ -133,6 +142,7 @@ import Data.Vector.Instances () import CorePrelude hiding (print, undefined, (<>)) import ClassyPrelude.Classes +import qualified Data.Char as Char import Data.Sequences import Data.MonoTraversable import Data.Containers @@ -142,13 +152,43 @@ import Debug.Trace (trace, traceShow) import Data.Semigroup (Semigroup (..), WrappedMonoid (..)) import Prelude (Show (..)) +import Data.Time + ( UTCTime (..) + , Day (..) + , toGregorian + , fromGregorian + , formatTime + , parseTime + ) +import System.Locale (defaultTimeLocale) +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.HashSet as HashSet + +import Data.Textual.Encoding +import Data.Sequences.Lazy + tshow :: Show a => a -> Text tshow = fromList . Prelude.show tlshow :: Show a => a -> LText tlshow = fromList . Prelude.show +-- | Convert a character to lower case. +-- +-- Character-based case conversion is lossy in comparison to string-based 'Data.MonoTraversable.toLower'. +-- For instance, \'İ\' will be converted to \'i\', instead of \"i̇\". +charToLower :: Char -> Char +charToLower = Char.toLower + +-- | Convert a character to upper case. +-- +-- Character-based case conversion is lossy in comparison to string-based 'Data.MonoTraversable.toUpper'. +-- For instance, \'ß\' won't be converted to \"SS\". +charToUpper :: Char -> Char +charToUpper = Char.toUpper + -- Renames from mono-traversable pack :: IsSequence c => [Element c] -> c @@ -222,16 +262,16 @@ infixl 9 \\{-This comment teaches CPP correct behaviour -} -- | An alias for `difference`. -(\\) :: Container a => a -> a -> a +(\\) :: SetContainer a => a -> a -> a (\\) = difference {-# INLINE (\\) #-} -- | An alias for `intersection`. -intersect :: Container a => a -> a -> a +intersect :: SetContainer a => a -> a -> a intersect = intersection {-# INLINE intersect #-} -unions :: (MonoFoldable c, Container (Element c)) => c -> Element c +unions :: (MonoFoldable c, SetContainer (Element c)) => c -> Element c unions = ofoldl' union Monoid.mempty intercalate :: (Monoid (Element c), IsSequence c) => Element c -> c -> Element c @@ -424,3 +464,45 @@ fpFromText :: Text -> FilePath fpFromText = F.fromText + +-- Below is a lot of coding for classy-prelude! +-- These functions are restricted to lists right now. +-- Should eventually exist in mono-foldable and be extended to MonoFoldable +-- when doing that should re-run the haskell-ordnub benchmarks + +-- | same behavior as nub, but requires Hashable & Eq and is O(n log n) +-- https://github.com/nh2/haskell-ordnub +hashNub :: (Hashable a, Eq a) => [a] -> [a] +hashNub = go HashSet.empty + where + go _ [] = [] + go s (x:xs) | x `HashSet.member` s = go s xs + | otherwise = x : go (HashSet.insert x s) xs + +-- | same behavior as nub, but requires Ord and is O(n log n) +-- https://github.com/nh2/haskell-ordnub +ordNub :: (Ord a) => [a] -> [a] +ordNub = go Set.empty + where + go _ [] = [] + go s (x:xs) | x `Set.member` s = go s xs + | otherwise = x : go (Set.insert x s) xs + +-- | same behavior as nubBy, but requires Ord and is O(n log n) +-- https://github.com/nh2/haskell-ordnub +ordNubBy :: (Ord b) => (a -> b) -> (a -> a -> Bool) -> [a] -> [a] +ordNubBy p f = go Map.empty + -- When removing duplicates, the first function assigns the input to a bucket, + -- the second function checks whether it is already in the bucket (linear search). + where + go _ [] = [] + go m (x:xs) = let b = p x in case b `Map.lookup` m of + Nothing -> x : go (Map.insert b [x] m) xs + Just bucket + | elem_by f x bucket -> go m xs + | otherwise -> x : go (Map.insert b (x:bucket) m) xs + + -- From the Data.List source code. + elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool + elem_by _ _ [] = False + elem_by eq y (x:xs) = y `eq` x || elem_by eq y xs diff --git a/ClassyPrelude/Classes.hs b/ClassyPrelude/Classes.hs --- a/ClassyPrelude/Classes.hs +++ b/ClassyPrelude/Classes.hs @@ -18,17 +18,23 @@ import qualified Data.ByteString.Lazy as LByteString import qualified Data.Text as Text import qualified Data.Text.IO as Text -import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.IO as LText import qualified Filesystem.Path.CurrentOS as FilePath import qualified Data.Vector as Vector -import qualified Data.Vector.Unboxed as UVector +-- import qualified Data.Vector.Unboxed as UVector import qualified Data.Sequence as Seq -import Data.MonoTraversable -import Data.Sequences (fromStrict, IsSequence) +import Data.Sequences (IsSequence) +import Data.Sequences.Lazy (fromStrict) import Control.Monad (liftM) import System.IO (Handle) import qualified System.IO +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Reader +import qualified Data.IntMap as IntMap +import Data.Tree +import Data.Functor.Compose +import Data.Foldable (toList) class IsSequence a => IOData a where readFile :: MonadIO m => FilePath -> m a @@ -47,7 +53,7 @@ hGetLine = liftIO . ByteString.hGetLine hPut h = liftIO . ByteString.hPut h hPutStrLn h = liftIO . ByteString8.hPutStrLn h - hGetChunk = liftIO . flip ByteString.hGetSome 4096 + hGetChunk = liftIO . flip ByteString.hGetSome defaultChunkSize instance IOData LByteString where readFile = liftIO . LByteString.readFile . FilePath.encodeString writeFile fp = liftIO . LByteString.writeFile (FilePath.encodeString fp) @@ -92,128 +98,158 @@ hPutStrLn h = liftIO . System.IO.hPutStrLn h hGetChunk = liftM Text.unpack . hGetChunk -class CanZip c1 c2 withRes t | c1 -> c2 withRes t , c2 -> c1 where - zip :: c1 -> c2 -> t (Element c1, Element c2) - unzip :: t (Element c1, Element c2) -> (c1, c2) - zipWith :: (Element c1 -> Element c2 -> Element withRes) -> c1 -> c2 -> withRes -instance CanZip [a] [b] [c] [] where + +class Functor f => Zip f where + zipWith :: (a -> b -> c) -> f a -> f b -> f c + + zip :: f a -> f b -> f (a, b) + zip = zipWith (,) + + zap :: f (a -> b) -> f a -> f b + zap = zipWith id + + unzip :: f (a, b) -> (f a, f b) + unzip = fmap fst &&& fmap snd + +instance Zip [] where zip = List.zip - unzip = List.unzip zipWith = List.zipWith -instance CanZip (NonEmpty a) (NonEmpty b) (NonEmpty c) NonEmpty where + unzip = List.unzip +instance Zip NonEmpty where + zipWith = NonEmpty.zipWith zip = NonEmpty.zip unzip = NonEmpty.unzip - zipWith = NonEmpty.zipWith -instance CanZip (Vector a) (Vector b) (Vector c) Vector where +instance Zip Seq where + zip = Seq.zip + zipWith = Seq.zipWith + unzip = (Seq.fromList *** Seq.fromList) . List.unzip . toList +instance Zip Tree where + zipWith f (Node a as) (Node b bs) = Node (f a b) (zipWith (zipWith f) as bs) +instance Zip Vector where zip = Vector.zip unzip = Vector.unzip zipWith = Vector.zipWith -instance (Unbox a, Unbox b, Unbox c) => CanZip (UVector a) (UVector b) (UVector c) UVector where + {- +instance Zip UVector where zip = UVector.zip unzip = UVector.unzip zipWith = UVector.zipWith -instance CanZip (Seq a) (Seq b) (Seq c) Seq where - zip = Seq.zip - unzip = (\(a, b) -> (Seq.fromList a, Seq.fromList b)) . List.unzip . otoList - zipWith = Seq.zipWith -instance CanZip ByteString ByteString [a] [] where - zip = ByteString.zip - unzip = ByteString.unzip - zipWith = ByteString.zipWith -instance CanZip LByteString LByteString [a] [] where - zip = LByteString.zip - unzip = LByteString.unzip - zipWith = LByteString.zipWith -instance CanZip Text Text Text [] where - zip = Text.zip - unzip = (Text.pack *** Text.pack) . List.unzip - zipWith = Text.zipWith -instance CanZip LText LText LText [] where - zip = LText.zip - unzip = (LText.pack *** LText.pack) . List.unzip - zipWith = LText.zipWith + -} -class CanZip3 t a b c d | t -> a b c d where - zip3 :: t a -> t b -> t c -> t (a, b, c) - unzip3 :: t (a, b, c) -> (t a, t b, t c) - zipWith3 :: (a -> b -> c -> d) -> t a -> t b -> t c -> t d -instance CanZip3 [] a b c d where +instance Zip m => Zip (IdentityT m) where + zipWith f (IdentityT m) (IdentityT n) = IdentityT (zipWith f m n) +instance Zip ((->)a) where + zipWith f g h a = f (g a) (h a) +instance Zip m => Zip (ReaderT e m) where + zipWith f (ReaderT m) (ReaderT n) = ReaderT $ \a -> + zipWith f (m a) (n a) +instance Zip IntMap.IntMap where + zipWith = IntMap.intersectionWith +instance (Zip f, Zip g) => Zip (Compose f g) where + zipWith f (Compose a) (Compose b) = Compose $ zipWith (zipWith f) a b + +class Functor f => Zip3 f where + zipWith3 :: (a -> b -> c -> d) -> f a -> f b -> f c -> f d + + zip3 :: f a -> f b -> f c -> f (a, b, c) + zip3 = zipWith3 (\x y z -> (x,y,z)) + + zap3 :: f (a -> b -> c) -> f a -> f b -> f c + zap3 = zipWith3 id + + unzip3 :: f (a, b, c) -> (f a, f b, f c) + -- unzip3 = fmap (\(x,_,_)->x) &&& fmap (\(_,x,_)->x) &&& fmap (\(_,_,x)->x) + +instance Zip3 [] where zip3 = List.zip3 unzip3 = List.unzip3 zipWith3 = List.zipWith3 -instance CanZip3 Vector a b c d where +instance Zip3 Vector where zip3 = Vector.zip3 unzip3 = Vector.unzip3 zipWith3 = Vector.zipWith3 -instance (Unbox a, Unbox b, Unbox c, Unbox d) => CanZip3 UVector a b c d where - zip3 = UVector.zip3 - unzip3 = UVector.unzip3 - zipWith3 = UVector.zipWith3 -instance CanZip3 Seq a b c d where +instance Zip3 Seq where zip3 = Seq.zip3 - unzip3 = (\(a, b, c) -> (Seq.fromList a, Seq.fromList b, Seq.fromList c)) . List.unzip3 . otoList + unzip3 = (\(a, b, c) -> (Seq.fromList a, Seq.fromList b, Seq.fromList c)) . List.unzip3 . toList zipWith3 = Seq.zipWith3 -class CanZip4 t a b c d e | t -> a b c d e where - zip4 :: t a -> t b -> t c -> t d -> t (a, b, c, d) - unzip4 :: t (a, b, c, d) -> (t a, t b, t c, t d) - zipWith4 :: (a -> b -> c -> d -> e) -> t a -> t b -> t c -> t d -> t e -instance CanZip4 [] a b c d e where +class Functor f => Zip4 f where + zipWith4 :: (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e + + zip4 :: f a -> f b -> f c -> f d -> f (a, b, c, d) + zip4 = zipWith4 (\w x y z -> (w, x,y,z)) + + zap4 :: f (a -> b -> c -> d) -> f a -> f b -> f c -> f d + zap4 = zipWith4 id + + unzip4 :: f (a, b, c, d) -> (f a, f b, f c, f d) + +instance Zip4 [] where zip4 = List.zip4 unzip4 = List.unzip4 zipWith4 = List.zipWith4 -instance CanZip4 Vector a b c d e where +instance Zip4 Vector where zip4 = Vector.zip4 unzip4 = Vector.unzip4 zipWith4 = Vector.zipWith4 -instance (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e) => CanZip4 UVector a b c d e where - zip4 = UVector.zip4 - unzip4 = UVector.unzip4 - zipWith4 = UVector.zipWith4 -instance CanZip4 Seq a b c d e where +instance Zip4 Seq where zip4 = Seq.zip4 - unzip4 = (\(a, b, c, d) -> (Seq.fromList a, Seq.fromList b, Seq.fromList c, Seq.fromList d)) . List.unzip4 . otoList + unzip4 = (\(a, b, c, d) -> (Seq.fromList a, Seq.fromList b, Seq.fromList c, Seq.fromList d)) . List.unzip4 . toList zipWith4 = Seq.zipWith4 -class CanZip5 t a b c d e f | t -> a b c d e f where - zip5 :: t a -> t b -> t c -> t d -> t e -> t (a, b, c, d, e) - unzip5 :: t (a, b, c, d, e) -> (t a, t b, t c, t d, t e) - zipWith5 :: (a -> b -> c -> d -> e -> f) -> t a -> t b -> t c -> t d -> t e -> t f -instance CanZip5 [] a b c d e f where +class Functor f => Zip5 f where + zipWith5 :: (a -> b -> c -> d -> e -> g) -> f a -> f b -> f c -> f d -> f e -> f g + + zip5 :: f a -> f b -> f c -> f d -> f e -> f (a, b, c, d, e) + zip5 = zipWith5 (\v w x y z -> (v,w,x,y,z)) + + zap5 :: f (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e + zap5 = zipWith5 id + + unzip5 :: f (a, b, c, d, e) -> (f a, f b, f c, f d, f e) + +instance Zip5 [] where zip5 = List.zip5 unzip5 = List.unzip5 zipWith5 = List.zipWith5 -instance CanZip5 Vector a b c d e f where +instance Zip5 Vector where zip5 = Vector.zip5 unzip5 = Vector.unzip5 zipWith5 = Vector.zipWith5 -instance (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f) => CanZip5 UVector a b c d e f where - zip5 = UVector.zip5 - unzip5 = UVector.unzip5 - zipWith5 = UVector.zipWith5 -class CanZip6 t a b c d e f g | t -> a b c d e f g where - zip6 :: t a -> t b -> t c -> t d -> t e -> t f -> t (a, b, c, d, e, f) - unzip6 :: t (a, b, c, d, e, f) -> (t a, t b, t c, t d, t e, t f) - zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> t a -> t b -> t c -> t d -> t e -> t f -> t g -instance CanZip6 [] a b c d e f g where +class Functor f => Zip6 f where + zipWith6 :: (a -> b -> c -> d -> e -> g -> h) -> f a -> f b -> f c -> f d -> f e -> f g -> f h + + zip6 :: f a -> f b -> f c -> f d -> f e -> f g -> f (a, b, c, d, e, g) + zip6 = zipWith6 (\u v w x y z -> (u, v,w,x,y,z)) + + zap6 :: f (a -> b -> c -> d -> e -> g) -> f a -> f b -> f c -> f d -> f e -> f g + zap6 = zipWith6 id + + unzip6 :: f (a, b, c, d, e, g) -> (f a, f b, f c, f d, f e, f g) + +instance Zip6 [] where zip6 = List.zip6 unzip6 = List.unzip6 zipWith6 = List.zipWith6 -instance CanZip6 Vector a b c d e f g where +instance Zip6 Vector where zip6 = Vector.zip6 unzip6 = Vector.unzip6 zipWith6 = Vector.zipWith6 -instance (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f, Unbox g) => CanZip6 UVector a b c d e f g where - zip6 = UVector.zip6 - unzip6 = UVector.unzip6 - zipWith6 = UVector.zipWith6 -class CanZip7 t a b c d e f g h | t -> a b c d e f g h where - zip7 :: t a -> t b -> t c -> t d -> t e -> t f -> t g -> t (a, b, c, d, e, f, g) - unzip7 :: t (a, b, c, d, e, f, g) -> (t a, t b, t c, t d, t e, t f, t g) - zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> t a -> t b -> t c -> t d -> t e -> t f -> t g -> t h -instance CanZip7 [] a b c d e f g h where +class Functor f => Zip7 f where + zipWith7 :: (a -> b -> c -> d -> e -> g -> h -> i) -> f a -> f b -> f c -> f d -> f e -> f g -> f h -> f i + + zip7 :: f a -> f b -> f c -> f d -> f e -> f g -> f h -> f (a, b, c, d, e, g, h) + zip7 = zipWith7 (\t u v w x y z -> (t,u,v,w,x,y,z)) + + zap7 :: f (a -> b -> c -> d -> e -> g -> h) -> f a -> f b -> f c -> f d -> f e -> f g -> f h + zap7 = zipWith7 id + + unzip7 :: f (a, b, c, d, e, g, h) -> (f a, f b, f c, f d, f e, f g, f h) + -- unzip3 = fmap (\(x,_,_)->x) &&& fmap (\(_,x,_)->x) &&& fmap (\(_,_,x)->x) + +instance Zip7 [] where zip7 = List.zip7 unzip7 = List.unzip7 zipWith7 = List.zipWith7 diff --git a/Data/Sequences/Lazy.hs b/Data/Sequences/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/Sequences/Lazy.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Data.Sequences.Lazy where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Sequences +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +class (IsSequence l, IsSequence s) => LazySequence l s | l -> s, s -> l where + toChunks :: l -> [s] + fromChunks :: [s] -> l + toStrict :: l -> s + fromStrict :: s -> l + +instance LazySequence L.ByteString S.ByteString where + toChunks = L.toChunks + fromChunks = L.fromChunks + toStrict = S.concat . L.toChunks + fromStrict = L.fromChunks . return + +instance LazySequence TL.Text T.Text where + toChunks = TL.toChunks + fromChunks = TL.fromChunks + toStrict = TL.toStrict + fromStrict = TL.fromStrict diff --git a/Data/Textual/Encoding.hs b/Data/Textual/Encoding.hs new file mode 100644 --- /dev/null +++ b/Data/Textual/Encoding.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Textual.Encoding where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Sequences +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Data.Word (Word8) + +class (Textual t, IsSequence b) => Utf8 t b | t -> b, b -> t where + encodeUtf8 :: t -> b + decodeUtf8 :: b -> t +instance (c ~ Char, w ~ Word8) => Utf8 [c] [w] where + encodeUtf8 = L.unpack . TL.encodeUtf8 . TL.pack + decodeUtf8 = TL.unpack . TL.decodeUtf8With lenientDecode . L.pack +instance Utf8 T.Text S.ByteString where + encodeUtf8 = T.encodeUtf8 + decodeUtf8 = T.decodeUtf8With lenientDecode +instance Utf8 TL.Text L.ByteString where + encodeUtf8 = TL.encodeUtf8 + decodeUtf8 = TL.decodeUtf8With lenientDecode diff --git a/classy-prelude.cabal b/classy-prelude.cabal --- a/classy-prelude.cabal +++ b/classy-prelude.cabal @@ -1,5 +1,5 @@ name: classy-prelude -version: 0.6.0.1 +version: 0.7.0 synopsis: A typeclass-based Prelude. description: Focuses on using common typeclasses when possible, and creating new ones to avoid name clashing. Exposes many recommended datastructures (Map, ByteString, etc) directly without requiring long import lists and qualified modules. homepage: https://github.com/snoyberg/classy-prelude @@ -14,6 +14,8 @@ library exposed-modules: ClassyPrelude ClassyPrelude.Classes + Data.Sequences.Lazy + Data.Textual.Encoding build-depends: base >= 4 && < 5 , basic-prelude >= 0.3.6 && < 0.4 , system-filepath >= 0.4 && < 0.5 @@ -28,9 +30,11 @@ , monad-control , async >= 2.0 , deepseq - , mono-traversable < 0.2 + , mono-traversable >= 0.2 , semigroups , vector-instances + , old-locale + , time ghc-options: -Wall -fno-warn-orphans test-suite test diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -219,7 +219,8 @@ utf8Props :: ( Eq t , Show t , Arbitrary t - , Textual t b + , Textual t + , Utf8 t b ) => t -> Spec