diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# 0.4 + +- Add instances for type-classes in current `base`, `binary`, `deepseq` and `hashable` +- Add combinators mirroring `Data.Maybe`, `Data.Either` and `Data.Tuple` +- Add `Strict lazy strict` type-class with `toStrict` / `toLazy` + conversion functions +- Modules are explicitly marked `Safe` or `Trustworthy` +- Add strict `These` +- `:!:` (`Pair` constructor) is non-associative diff --git a/Data/Strict.hs b/Data/Strict.hs deleted file mode 100644 --- a/Data/Strict.hs +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Strict --- Copyright : (c) 2006-2007 Roman Leshchinskiy --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Roman Leshchinskiy --- Stability : experimental --- Portability : portable --- --- Strict versions of some standard Haskell types. --- ------------------------------------------------------------------------------ - -module Data.Strict ( - module Data.Strict.Tuple - , module Data.Strict.Maybe - , module Data.Strict.Either -) where - -import Data.Strict.Tuple -import Data.Strict.Maybe -import Data.Strict.Either - diff --git a/Data/Strict/Either.hs b/Data/Strict/Either.hs deleted file mode 100644 --- a/Data/Strict/Either.hs +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Strict.Either --- Copyright : (c) 2006-2007 Roman Leshchinskiy --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Roman Leshchinskiy --- Stability : experimental --- Portability : portable --- --- Strict @Either@. --- --- Same as the standard Haskell @Either@, but @Left _|_ = Right _|_ = _|_@ --- ------------------------------------------------------------------------------ - -module Data.Strict.Either ( - Either(..) - , either - , isLeft, isRight - , fromLeft, fromRight -) where - -import Prelude hiding( Either(..), either ) - --- | The strict choice type. -data Either a b = Left !a | Right !b deriving(Eq, Ord, Read, Show) - -instance Functor (Either a) where - fmap _ (Left x) = Left x - fmap f (Right y) = Right (f y) - --- | Case analysis: if the value is @'Left' a@, apply the first function to @a@; --- if it is @'Right' b@, apply the second function to @b@. -either :: (a -> c) -> (b -> c) -> Either a b -> c -either f _ (Left x) = f x -either _ g (Right y) = g y - --- | Yields 'True' iff the argument is of the form @Left _@. --- -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft _ = False - --- | Yields 'True' iff the argument is of the form @Right _@. --- -isRight :: Either a b -> Bool -isRight (Right _) = True -isRight _ = False - --- | Extracts the element out of a 'Left' and throws an error if the argument --- is a 'Right'. -fromLeft :: Either a b -> a -fromLeft (Left x) = x -fromLeft _ = error "Data.Strict.Either.fromLeft: Right" - --- | Extracts the element out of a 'Right' and throws an error if the argument --- is a 'Left'. -fromRight :: Either a b -> b -fromRight (Right x) = x -fromRight _ = error "Data.Strict.Either.fromRight: Left" - - - diff --git a/Data/Strict/Maybe.hs b/Data/Strict/Maybe.hs deleted file mode 100644 --- a/Data/Strict/Maybe.hs +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Strict.Maybe --- Copyright : (c) 2006-2007 Roman Leshchinskiy --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Roman Leshchinskiy --- Stability : experimental --- Portability : portable --- --- Strict @Maybe@. --- --- Same as the standard Haskell @Maybe@, but @Just _|_ = _|_@ --- --- Note that strict @Maybe@ is not a monad since --- @ return _|_ >>= f = _|_ @ --- which is not necessarily the same as @f _|_@. --- ------------------------------------------------------------------------------ - -module Data.Strict.Maybe ( - Maybe(..) - , isJust - , isNothing - , fromJust - , fromMaybe - , maybe -) where - -import Prelude hiding( Maybe(..), maybe ) - --- | The type of strict optional values. -data Maybe a = Nothing | Just !a deriving(Eq, Ord, Show, Read) - -instance Functor Maybe where - fmap _ Nothing = Nothing - fmap f (Just x) = Just (f x) - --- | Yields 'True' iff the argument is of the form @Just _@. -isJust :: Maybe a -> Bool -isJust Nothing = False -isJust _ = True - --- | Yields 'True' iff the argument is 'Nothing'. -isNothing :: Maybe a -> Bool -isNothing Nothing = True -isNothing _ = False - --- | Extracts the element out of a 'Just' and throws an error if the argument --- is 'Nothing'. -fromJust :: Maybe a -> a -fromJust Nothing = error "Data.Strict.Maybe.fromJust: Nothing" -fromJust (Just x) = x - --- | Given a default value and a 'Maybe', yield the default value if the --- 'Maybe' argument is 'Nothing' and extract the value out of the 'Just' --- otherwise. -fromMaybe :: a -> Maybe a -> a -fromMaybe x Nothing = x -fromMaybe _ (Just y) = y - --- | Given a default value, a function and a 'Maybe' value, yields the default --- value if the 'Maybe' value is 'Nothing' and applies the function to the --- value stored in the 'Just' otherwise. -maybe :: b -> (a -> b) -> Maybe a -> b -maybe x _ Nothing = x -maybe _ f (Just y) = f y - diff --git a/Data/Strict/Tuple.hs b/Data/Strict/Tuple.hs deleted file mode 100644 --- a/Data/Strict/Tuple.hs +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Strict.Tuple --- Copyright : (c) 2006-2007 Roman Leshchinskiy --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Roman Leshchinskiy --- Stability : experimental --- Portability : portable --- --- Strict pairs. --- --- Same as regular Haskell pairs, but @(x :*: _|_) = (_|_ :*: y) = _|_@ --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fglasgow-exts #-} - -module Data.Strict.Tuple ( - Pair(..) -#ifndef __HADDOCK__ -#ifdef __GLASGOW_HASKELL__ - , (:!:) -#endif -#endif - , fst - , snd - , curry - , uncurry -) where - -import Prelude hiding( fst, snd, curry, uncurry ) -import Data.Array (Ix) - -infixl 2 :!: - --- | The type of strict pairs. -data Pair a b = !a :!: !b deriving(Eq, Ord, Show, Read, Bounded, Ix) - -#ifndef __HADDOCK__ -#ifdef __GLASGOW_HASKELL__ --- This gives a nicer syntax for the type but only works in GHC for now. -type (:!:) = Pair -#endif -#endif - --- | Extract the first component of a strict pair. -fst :: Pair a b -> a -fst (x :!: _) = x - --- | Extract the second component of a strict pair. -snd :: Pair a b -> b -snd (_ :!: y) = y - --- | Curry a function on strict pairs. -curry :: (Pair a b -> c) -> a -> b -> c -curry f x y = f (x :!: y) - --- | Convert a curried function to a function on strict pairs. -uncurry :: (a -> b -> c) -> Pair a b -> c -uncurry f (x :!: y) = f x y - diff --git a/System/IO/Strict.hs b/System/IO/Strict.hs deleted file mode 100644 --- a/System/IO/Strict.hs +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : System.IO.Strict --- Copyright : (c) Don Stewart 2007 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : dons@galois.com --- Stability : stable --- Portability : portable --- --- The standard IO input functions using strict IO. --- ------------------------------------------------------------------------------ - -module System.IO.Strict ( - - -- * Strict Handle IO - hGetContents, -- :: Handle -> IO [Char] - - -- * Strict String IO wrappers - getContents, -- :: IO String - readFile, -- :: FilePath -> IO String - interact -- :: (String -> String) -> IO () - - ) where - -import Prelude ( String, (>>=), seq, return, (.), (=<<), FilePath, length) -import System.IO (IO) -import qualified System.IO as IO - --- ----------------------------------------------------------------------------- --- Strict hGetContents - --- | Computation 'hGetContents' @hdl@ returns the list of characters --- corresponding to the unread portion of the channel or file managed --- by @hdl@, which is immediate closed. --- --- Items are read strictly from the input Handle. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. - -hGetContents :: IO.Handle -> IO.IO String -hGetContents h = IO.hGetContents h >>= \s -> length s `seq` return s - --- ----------------------------------------------------------------------------- --- Standard IO - --- | The 'getContents' operation returns all user input as a single string, --- which is read stirctly (same as 'hGetContents' 'stdin'). - -getContents :: IO String -getContents = hGetContents IO.stdin -{-# INLINE getContents #-} - --- | The 'interact' function takes a function of type @String->String@ --- as its argument. The entire input from the standard input device is --- passed to this function as its argument, and the resulting string is --- output on the standard output device. - -interact :: (String -> String) -> IO () -interact f = IO.putStr . f =<< getContents -{-# INLINE interact #-} - --- | The 'readFile' function reads a file and --- returns the contents of the file as a string. --- The file is read strictly, as with 'getContents'. - -readFile :: FilePath -> IO String -readFile name = IO.openFile name IO.ReadMode >>= hGetContents -{-# INLINE readFile #-} diff --git a/src/Data/Strict.hs b/src/Data/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Data/Strict.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Safe #-} + +-- | Strict versions of some standard Haskell types. +module Data.Strict ( + module Data.Strict.Classes + , module Data.Strict.These + , module Data.Strict.Tuple + , module Data.Strict.Maybe + , module Data.Strict.Either +) where + +import Data.Strict.Classes +import Data.Strict.These +import Data.Strict.Tuple +import Data.Strict.Maybe +import Data.Strict.Either diff --git a/src/Data/Strict/Classes.hs b/src/Data/Strict/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Strict/Classes.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FunctionalDependencies #-} +#if MIN_VERSION_base(4,8,0) +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +module Data.Strict.Classes ( + Strict (..), +) where + +import Prelude ((.)) +import qualified Prelude as L +import qualified Data.These as L + +import Data.Strict.These +import Data.Strict.Tuple +import Data.Strict.Maybe +import Data.Strict.Either + +import qualified Control.Monad.ST.Lazy as L +import qualified Control.Monad.ST.Strict as S +import qualified Control.Monad.Trans.RWS.Lazy as L +import qualified Control.Monad.Trans.RWS.Strict as S +import qualified Control.Monad.Trans.State.Lazy as L +import qualified Control.Monad.Trans.State.Strict as S +import qualified Control.Monad.Trans.Writer.Lazy as L +import qualified Control.Monad.Trans.Writer.Strict as S +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT + +-- | Ad hoc conversion between "strict" and "lazy" versions of a structure. +-- +-- Unfortunately all externally defined instances are doomed to +-- be orphans: https://gitlab.haskell.org/ghc/ghc/-/issues/11999 +-- See also https://qfpl.io/posts/orphans-and-fundeps/index.html for +-- +class Strict lazy strict | lazy -> strict, strict -> lazy where + toStrict :: lazy -> strict + toLazy :: strict -> lazy + +instance Strict (L.Maybe a) (Maybe a) where + toStrict L.Nothing = Nothing + toStrict (L.Just x) = Just x + + toLazy Nothing = L.Nothing + toLazy (Just x) = L.Just x + +instance Strict (a, b) (Pair a b) where + toStrict (a, b) = a :!: b + toLazy (a :!: b) = (a, b) + +instance Strict (L.Either a b) (Either a b) where + toStrict (L.Left x) = Left x + toStrict (L.Right y) = Right y + + toLazy (Left x) = L.Left x + toLazy (Right y) = L.Right y + +instance Strict (L.These a b) (These a b) where + toStrict (L.This x) = This x + toStrict (L.That y) = That y + toStrict (L.These x y) = These x y + + toLazy (This x) = L.This x + toLazy (That y) = L.That y + toLazy (These x y) = L.These x y + +instance Strict LBS.ByteString BS.ByteString where +#if MIN_VERSION_bytestring(0,10,0) + toStrict = LBS.toStrict + toLazy = LBS.fromStrict +#else + toStrict = BS.concat . LBS.toChunks + toLazy = LBS.fromChunks . L.return {- singleton -} +#endif + +instance Strict LT.Text T.Text where + toStrict = LT.toStrict + toLazy = LT.fromStrict + +instance Strict (L.ST s a) (S.ST s a) where + toStrict = L.lazyToStrictST + toLazy = L.strictToLazyST + +instance Strict (L.RWST r w s m a) (S.RWST r w s m a) where + toStrict = S.RWST . L.runRWST + toLazy = L.RWST . S.runRWST + +instance Strict (L.StateT s m a) (S.StateT s m a) where + toStrict = S.StateT . L.runStateT + toLazy = L.StateT . S.runStateT + +instance Strict (L.WriterT w m a) (S.WriterT w m a) where + toStrict = S.WriterT . L.runWriterT + toLazy = L.WriterT . S.runWriterT diff --git a/src/Data/Strict/Either.hs b/src/Data/Strict/Either.hs new file mode 100644 --- /dev/null +++ b/src/Data/Strict/Either.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} + +#if MIN_VERSION_base(4,9,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#else +#if MIN_VERSION_transformers(0,5,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#else +#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#endif +#endif +#endif + +----------------------------------------------------------------------------- +-- | +-- +-- The strict variant of the standard Haskell 'L.Either' type and the +-- corresponding variants of the functions from "Data.Either". +-- +-- Note that the strict 'Either' type is not an applicative functor, and +-- therefore also no monad. The reasons are the same as the ones for the +-- strict @Maybe@ type, which are explained in "Data.Maybe.Strict". +-- +----------------------------------------------------------------------------- + +module Data.Strict.Either ( + Either(..) + , either + , isLeft, isRight + , fromLeft, fromRight + , lefts, rights + , partitionEithers +) where + +-- import parts explicitly, helps with compatibility +import Prelude ( Functor (..), Eq (..), Ord (..), Show (..), Read (..), Bool (..), (.), ($) + , error, Ordering (..), showParen, showString, lex, return, readParen) +import Control.Applicative (pure, (<$>)) +import Data.Semigroup (Semigroup (..)) +import Data.Foldable (Foldable (..)) +import Data.Traversable (Traversable (..)) + +-- Lazy variants +import qualified Prelude as L + +import Control.DeepSeq (NFData (..)) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Binary (Binary (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Hashable (Hashable(..)) +import Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..)) +import GHC.Generics (Generic) +import Data.Data (Data (..), Typeable) + +#if __GLASGOW_HASKELL__ >= 706 +import GHC.Generics (Generic1) +#endif + +#if MIN_VERSION_deepseq(1,4,3) +import Control.DeepSeq (NFData1 (..), NFData2 (..)) +#endif + +#ifdef MIN_VERSION_assoc +import Data.Bifunctor.Assoc (Assoc (..)) +import Data.Bifunctor.Swap (Swap (..)) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +import Data.Functor.Classes + (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Read1 (..), Read2 (..), + Show1 (..), Show2 (..)) +#else +import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) +#endif + +-- | The strict choice type. +data Either a b = Left !a | Right !b + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic +#if __GLASGOW_HASKELL__ >= 706 + , Generic1 +#endif + ) + +toStrict :: L.Either a b -> Either a b +toStrict (L.Left x) = Left x +toStrict (L.Right y) = Right y + +toLazy :: Either a b -> L.Either a b +toLazy (Left x) = L.Left x +toLazy (Right y) = L.Right y + +-- | Case analysis: if the value is @'Left' a@, apply the first function to @a@; +-- if it is @'Right' b@, apply the second function to @b@. +either :: (a -> c) -> (b -> c) -> Either a b -> c +either f _ (Left x) = f x +either _ g (Right y) = g y + +-- | Yields 'True' iff the argument is of the form @Left _@. +-- +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft _ = False + +-- | Yields 'True' iff the argument is of the form @Right _@. +-- +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _ = False + +-- | Extracts the element out of a 'Left' and throws an error if the argument +-- is a 'Right'. +fromLeft :: Either a b -> a +fromLeft (Left x) = x +fromLeft _ = error "Data.Strict.Either.fromLeft: Right" + +-- | Extracts the element out of a 'Right' and throws an error if the argument +-- is a 'Left'. +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = error "Data.Strict.Either.fromRight: Left" + +-- | Analogous to 'L.lefts' in "Data.Either". +lefts :: [Either a b] -> [a] +lefts x = [a | Left a <- x] + +-- | Analogous to 'L.rights' in "Data.Either". +rights :: [Either a b] -> [b] +rights x = [a | Right a <- x] + +-- | Analogous to 'L.partitionEithers' in "Data.Either". +partitionEithers :: [Either a b] -> ([a],[b]) +partitionEithers = + L.foldr (either left right) ([],[]) + where + left a ~(l, r) = (a:l, r) + right a ~(l, r) = (l, a:r) + +-- Instances +------------ + +instance Functor (Either a) where + fmap _ (Left x) = Left x + fmap f (Right y) = Right (f y) + +instance Foldable (Either e) where + foldr _ y (Left _) = y + foldr f y (Right x) = f x y + + foldl _ y (Left _) = y + foldl f y (Right x) = f y x + +instance Traversable (Either e) where + traverse _ (Left x) = pure (Left x) + traverse f (Right x) = Right <$> f x + +instance Semigroup (Either a b) where + Left _ <> b = b + a <> _ = a + +-- deepseq +instance (NFData a, NFData b) => NFData (Either a b) where + rnf = rnf . toLazy + +#if MIN_VERSION_deepseq(1,4,3) +instance (NFData a) => NFData1 (Either a) where + liftRnf rnfA = liftRnf rnfA . toLazy + +instance NFData2 Either where + liftRnf2 rnfA rnfB = liftRnf2 rnfA rnfB . toLazy +#endif + +-- binary +instance (Binary a, Binary b) => Binary (Either a b) where + put = put . toLazy + get = toStrict <$> get + +-- bifunctors +instance Bifunctor Either where + bimap f _ (Left a) = Left (f a) + bimap _ g (Right a) = Right (g a) + first f = either (Left . f) Right + second g = either Left (Right . g) + +instance Bifoldable Either where + bifold (Left a) = a + bifold (Right b) = b + bifoldMap = either + bifoldr f _ c (Left a) = f a c + bifoldr _ g c (Right b) = g b c + bifoldl f _ c (Left a) = f c a + bifoldl _ g c (Right b) = g c b + +instance Bitraversable Either where + bitraverse f _ (Left a) = fmap Left (f a) + bitraverse _ g (Right b) = fmap Right (g b) + +-- hashable +instance (Hashable a, Hashable b) => Hashable (Either a b) where + hashWithSalt salt = hashWithSalt salt . toLazy + +instance (Hashable a) => Hashable1 (Either a) where + liftHashWithSalt hashA salt = liftHashWithSalt hashA salt . toLazy + +instance Hashable2 Either where + liftHashWithSalt2 hashA hashB salt = liftHashWithSalt2 hashA hashB salt . toLazy + +-- assoc +#ifdef MIN_VERSION_assoc +instance Assoc Either where + assoc (Left (Left a)) = Left a + assoc (Left (Right b)) = Right (Left b) + assoc (Right c) = Right (Right c) + + unassoc (Left a) = Left (Left a) + unassoc (Right (Left b)) = Left (Right b) + unassoc (Right (Right c)) = Right c + +instance Swap Either where + swap (Left x) = Right x + swap (Right x) = Left x +#endif + +-- Data.Functor.Classes +#ifdef LIFTED_FUNCTOR_CLASSES +instance Eq2 Either where + liftEq2 f _ (Left a) (Left a') = f a a' + liftEq2 _ g (Right b) (Right b') = g b b' + liftEq2 _ _ _ _ = False + +instance Eq a => Eq1 (Either a) where + liftEq = liftEq2 (==) + +instance Ord2 Either where + liftCompare2 f _ (Left a) (Left a') = f a a' + liftCompare2 _ _ (Left _) _ = LT + liftCompare2 _ _ _ (Left _) = GT + liftCompare2 _ g (Right b) (Right b') = g b b' + +instance Ord a => Ord1 (Either a) where + liftCompare = liftCompare2 compare + +instance Show a => Show1 (Either a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Show2 Either where + liftShowsPrec2 sa _ _sb _ d (Left a) = showParen (d > 10) + $ showString "Left " + . sa 11 a + liftShowsPrec2 _sa _ sb _ d (Right b) = showParen (d > 10) + $ showString "Right " + . sb 11 b + +instance Read2 Either where + liftReadsPrec2 ra _ rb _ d = readParen (d > 10) $ \s -> cons s + where + cons s0 = do + (ident, s1) <- lex s0 + case ident of + "Left" -> do + (a, s2) <- ra 11 s1 + return (Left a, s2) + "Right" -> do + (b, s2) <- rb 11 s1 + return (Right b, s2) + _ -> [] + +instance Read a => Read1 (Either a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +#else +instance Eq a => Eq1 (Either a) where eq1 = (==) +instance Ord a => Ord1 (Either a) where compare1 = compare +instance Show a => Show1 (Either a) where showsPrec1 = showsPrec +instance Read a => Read1 (Either a) where readsPrec1 = readsPrec +#endif diff --git a/src/Data/Strict/Maybe.hs b/src/Data/Strict/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Strict/Maybe.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} + +#if MIN_VERSION_base(4,9,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#else +#if MIN_VERSION_transformers(0,5,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#else +#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#endif +#endif +#endif + +----------------------------------------------------------------------------- +-- | +-- +-- The strict variant of the standard Haskell 'L.Maybe' type and the +-- corresponding variants of the functions from "Data.Maybe". +-- +-- Note that in contrast to the standard lazy 'L.Maybe' type, the strict +-- 'Maybe' type is not an applicative functor, and therefore also not a monad. +-- The problem is the /homomorphism/ law, which states that +-- +-- @'pure' f '<*>' 'pure' x = 'pure' (f x) -- must hold for all f@ +-- +-- This law does not hold for the expected applicative functor instance of +-- 'Maybe', as this instance does not satisfy @pure f \<*\> pure _|_ = pure (f +-- _|_)@ for @f = const@. +-- +----------------------------------------------------------------------------- + +module Data.Strict.Maybe ( + Maybe(..) + , isJust + , isNothing + , fromJust + , fromMaybe + , maybe + , listToMaybe + , maybeToList + , catMaybes + , mapMaybe +) where + +-- import parts explicitly, helps with compatibility +import Prelude (Functor (..), Eq (..), Ord (..), Show (..), Read (..), Bool (..), (.) + ,error, Ordering (..), ($), showString, showParen, return, lex, readParen) +import Control.Applicative (pure, (<$>)) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Foldable (Foldable (..)) +import Data.Traversable (Traversable (..)) + +-- Lazy variants +import qualified Prelude as L + +import Control.DeepSeq (NFData (..)) +import Data.Binary (Binary (..)) +import Data.Hashable (Hashable(..)) +import Data.Hashable.Lifted (Hashable1 (..)) +import GHC.Generics (Generic) +import Data.Data (Data (..), Typeable) + + +#if __GLASGOW_HASKELL__ >= 706 +import GHC.Generics (Generic1) +#endif + +#if MIN_VERSION_deepseq(1,4,3) +import Control.DeepSeq (NFData1 (..)) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) +#else +import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) +#endif + +-- | The type of strict optional values. +data Maybe a = Nothing | Just !a + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic +#if __GLASGOW_HASKELL__ >= 706 + , Generic1 +#endif + ) + +toStrict :: L.Maybe a -> Maybe a +toStrict L.Nothing = Nothing +toStrict (L.Just x) = Just x + +toLazy :: Maybe a -> L.Maybe a +toLazy Nothing = L.Nothing +toLazy (Just x) = L.Just x + +-- | Yields 'True' iff the argument is of the form @Just _@. +isJust :: Maybe a -> Bool +isJust Nothing = False +isJust _ = True + +-- | Yields 'True' iff the argument is 'Nothing'. +isNothing :: Maybe a -> Bool +isNothing Nothing = True +isNothing _ = False + +-- | Extracts the element out of a 'Just' and throws an error if the argument +-- is 'Nothing'. +fromJust :: Maybe a -> a +fromJust Nothing = error "Data.Strict.Maybe.fromJust: Nothing" +fromJust (Just x) = x + +-- | Given a default value and a 'Maybe', yield the default value if the +-- 'Maybe' argument is 'Nothing' and extract the value out of the 'Just' +-- otherwise. +fromMaybe :: a -> Maybe a -> a +fromMaybe x Nothing = x +fromMaybe _ (Just y) = y + +-- | Given a default value, a function and a 'Maybe' value, yields the default +-- value if the 'Maybe' value is 'Nothing' and applies the function to the +-- value stored in the 'Just' otherwise. +maybe :: b -> (a -> b) -> Maybe a -> b +maybe x _ Nothing = x +maybe _ f (Just y) = f y + +-- | Analogous to 'L.listToMaybe' in "Data.Maybe". +listToMaybe :: [a] -> Maybe a +listToMaybe [] = Nothing +listToMaybe (a:_) = Just a + +-- | Analogous to 'L.maybeToList' in "Data.Maybe". +maybeToList :: Maybe a -> [a] +maybeToList Nothing = [] +maybeToList (Just x) = [x] + +-- | Analogous to 'L.catMaybes' in "Data.Maybe". +catMaybes :: [Maybe a] -> [a] +catMaybes ls = [x | Just x <- ls] + +-- | Analogous to 'L.mapMaybe' in "Data.Maybe". +mapMaybe :: (a -> Maybe b) -> [a] -> [b] +mapMaybe _ [] = [] +mapMaybe f (x:xs) = case f x of + Nothing -> rs + Just r -> r:rs + where + rs = mapMaybe f xs + +-- Instances +------------ + +instance Semigroup a => Semigroup (Maybe a) where + Nothing <> m = m + m <> Nothing = m + Just x1 <> Just x2 = Just (x1 <> x2) + +#if MIN_VERSION_base(4,11,0) +instance Semigroup a => Monoid (Maybe a) where + mempty = Nothing +#else +instance Monoid a => Monoid (Maybe a) where + mempty = Nothing + + Nothing `mappend` m = m + m `mappend` Nothing = m + Just x1 `mappend` Just x2 = Just (x1 `mappend` x2) +#endif + +instance Functor Maybe where + fmap _ Nothing = Nothing + fmap f (Just x) = Just (f x) + +instance Foldable Maybe where + foldMap _ Nothing = mempty + foldMap f (Just x) = f x + +instance Traversable Maybe where + traverse _ Nothing = pure Nothing + traverse f (Just x) = Just <$> f x + +-- deepseq +instance NFData a => NFData (Maybe a) where + rnf = rnf . toLazy + +#if MIN_VERSION_deepseq(1,4,3) +instance NFData1 Maybe where + liftRnf rnfA = liftRnf rnfA . toLazy +#endif + +-- binary +instance Binary a => Binary (Maybe a) where + put = put . toLazy + get = toStrict <$> get + +-- hashable +instance Hashable a => Hashable (Maybe a) where + hashWithSalt salt = hashWithSalt salt . toLazy + +instance Hashable1 Maybe where + liftHashWithSalt hashA salt = liftHashWithSalt hashA salt . toLazy + +-- Data.Functor.Classes +#ifdef LIFTED_FUNCTOR_CLASSES + +instance Eq1 Maybe where + liftEq f (Just a) (Just a') = f a a' + liftEq _ Nothing Nothing = True + liftEq _ _ _ = False + +instance Ord1 Maybe where + liftCompare _ Nothing Nothing = EQ + liftCompare _ Nothing (Just _) = LT + liftCompare _ (Just _) Nothing = GT + liftCompare f (Just a) (Just a') = f a a' + +instance Show1 Maybe where + liftShowsPrec _ _ _ Nothing = showString "Nothing" + liftShowsPrec sa _ d (Just a) = showParen (d > 10) + $ showString "Just " + . sa 11 a + +instance Read1 Maybe where + liftReadsPrec ra _ d = readParen (d > 10) cons where + cons s0 = do + (ident, s1) <- lex s0 + case ident of + "Nothing" -> return (Nothing, s1) + "Just" -> do + (a, s2) <- ra 11 s1 + return (Just a, s2) + _ -> [] + +#else +instance Eq1 Maybe where eq1 = (==) +instance Ord1 Maybe where compare1 = compare +instance Show1 Maybe where showsPrec1 = showsPrec +instance Read1 Maybe where readsPrec1 = readsPrec +#endif diff --git a/src/Data/Strict/These.hs b/src/Data/Strict/These.hs new file mode 100644 --- /dev/null +++ b/src/Data/Strict/These.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} + +#if MIN_VERSION_base(4,9,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#else +#if MIN_VERSION_transformers(0,5,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#else +#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#endif +#endif +#endif + +module Data.Strict.These ( + These(..) + + -- * Functions to get rid of 'These' + , these + , fromThese + , mergeThese + , mergeTheseWith + + -- * Partition + , partitionThese + , partitionHereThere + , partitionEithersNE + + -- * Distributivity + -- + -- | This distributivity combinators aren't isomorphisms! + , distrThesePair + , undistrThesePair + , distrPairThese + , undistrPairThese + ) where + +import Control.Applicative (Applicative (..), (<$>)) +import Control.DeepSeq (NFData (..)) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Binary (Binary (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Data (Data, Typeable) +import Data.Either (partitionEithers) +import Data.Foldable (Foldable (..)) +import Data.Hashable (Hashable (..)) +import Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Traversable (Traversable (..)) +import GHC.Generics (Generic) +import Prelude + (Bool (..), Either (..), Eq (..), Functor (..), Int, Monad (..), + Ord (..), Ordering (..), Read (..), Show (..), id, lex, readParen, + seq, showParen, showString, ($), (&&), (.)) + +import qualified Data.These as L + +#if MIN_VERSION_deepseq(1,4,3) +import Control.DeepSeq (NFData1 (..), NFData2 (..)) +#endif + +#if __GLASGOW_HASKELL__ >= 706 +import GHC.Generics (Generic1) +#endif + +#ifdef MIN_VERSION_assoc +import Data.Bifunctor.Assoc (Assoc (..)) +import Data.Bifunctor.Swap (Swap (..)) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +import Data.Functor.Classes + (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Read1 (..), Read2 (..), + Show1 (..), Show2 (..)) +#else +import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) +#endif + +-- $setup +-- >>> import Prelude (map) + +-- | The strict these type. +data These a b = This !a | That !b | These !a !b + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic +#if __GLASGOW_HASKELL__ >= 706 + , Generic1 +#endif + ) + +toStrict :: L.These a b -> These a b +toStrict (L.This x) = This x +toStrict (L.That y) = That y +toStrict (L.These x y) = These x y + +toLazy :: These a b -> L.These a b +toLazy (This x) = L.This x +toLazy (That y) = L.That y +toLazy (These x y) = L.These x y + +------------------------------------------------------------------------------- +-- Eliminators +------------------------------------------------------------------------------- + +-- | Case analysis for the 'These' type. +these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c +these l _ _ (This a) = l a +these _ r _ (That x) = r x +these _ _ lr (These a x) = lr a x + +-- | Takes two default values and produces a tuple. +fromThese :: a -> b -> These a b -> (a, b) +fromThese x y = these (`pair` y) (x `pair`) pair where + pair = (,) + +-- | Coalesce with the provided operation. +mergeThese :: (a -> a -> a) -> These a a -> a +mergeThese = these id id + +-- | 'bimap' and coalesce results with the provided operation. +mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c +mergeTheseWith f g op t = mergeThese op $ bimap f g t + +------------------------------------------------------------------------------- +-- Partitioning +------------------------------------------------------------------------------- + +-- | Select each constructor and partition them into separate lists. +partitionThese :: [These a b] -> ([a], [b], [(a, b)]) +partitionThese [] = ([], [], []) +partitionThese (t:ts) = case t of + This x -> (x : xs, ys, xys) + That y -> ( xs, y : ys, xys) + These x y -> ( xs, ys, (x,y) : xys) + where + ~(xs,ys,xys) = partitionThese ts + +-- | Select 'here' and 'there' elements and partition them into separate lists. +-- +partitionHereThere :: [These a b] -> ([a], [b]) +partitionHereThere [] = ([], []) +partitionHereThere (t:ts) = case t of + This x -> (x : xs, ys) + That y -> ( xs, y : ys) + These x y -> (x : xs, y : ys) + where + ~(xs,ys) = partitionHereThere ts + +-- | Like 'partitionEithers' but for 'NonEmpty' types. +-- +-- * either all are 'Left' +-- * either all are 'Right' +-- * or there is both 'Left' and 'Right' stuff +-- +-- /Note:/ this is not online algorithm. In the worst case it will traverse +-- the whole list before deciding the result constructor. +-- +-- >>> partitionEithersNE $ Left 'x' :| [Right 'y'] +-- These ('x' :| "") ('y' :| "") +-- +-- >>> partitionEithersNE $ Left 'x' :| map Left "yz" +-- This ('x' :| "yz") +-- +partitionEithersNE :: NonEmpty (Either a b) -> These (NonEmpty a) (NonEmpty b) +partitionEithersNE (x :| xs) = case (x, ls, rs) of + (Left y, ys, []) -> This (y :| ys) + (Left y, ys, z:zs) -> These (y :| ys) (z :| zs) + (Right z, [], zs) -> That (z :| zs) + (Right z, y:ys, zs) -> These (y :| ys) (z :| zs) + where + (ls, rs) = partitionEithers xs + + +------------------------------------------------------------------------------- +-- Distributivity +------------------------------------------------------------------------------- + +distrThesePair :: These (a, b) c -> (These a c, These b c) +distrThesePair (This (a, b)) = (This a, This b) +distrThesePair (That c) = (That c, That c) +distrThesePair (These (a, b) c) = (These a c, These b c) + +undistrThesePair :: (These a c, These b c) -> These (a, b) c +undistrThesePair (This a, This b) = This (a, b) +undistrThesePair (That c, That _) = That c +undistrThesePair (These a c, These b _) = These (a, b) c +undistrThesePair (This _, That c) = That c +undistrThesePair (This a, These b c) = These (a, b) c +undistrThesePair (That c, This _) = That c +undistrThesePair (That c, These _ _) = That c +undistrThesePair (These a c, This b) = These (a, b) c +undistrThesePair (These _ c, That _) = That c + + +distrPairThese :: (These a b, c) -> These (a, c) (b, c) +distrPairThese (This a, c) = This (a, c) +distrPairThese (That b, c) = That (b, c) +distrPairThese (These a b, c) = These (a, c) (b, c) + +undistrPairThese :: These (a, c) (b, c) -> (These a b, c) +undistrPairThese (This (a, c)) = (This a, c) +undistrPairThese (That (b, c)) = (That b, c) +undistrPairThese (These (a, c) (b, _)) = (These a b, c) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + + + +instance (Semigroup a, Semigroup b) => Semigroup (These a b) where + This a <> This b = This (a <> b) + This a <> That y = These a y + This a <> These b y = These (a <> b) y + That x <> This b = These b x + That x <> That y = That (x <> y) + That x <> These b y = These b (x <> y) + These a x <> This b = These (a <> b) x + These a x <> That y = These a (x <> y) + These a x <> These b y = These (a <> b) (x <> y) + +instance Functor (These a) where + fmap _ (This x) = This x + fmap f (That y) = That (f y) + fmap f (These x y) = These x (f y) + +instance Foldable (These a) where + foldr _ z (This _) = z + foldr f z (That x) = f x z + foldr f z (These _ x) = f x z + +instance Traversable (These a) where + traverse _ (This a) = pure $ This a + traverse f (That x) = That <$> f x + traverse f (These a x) = These a <$> f x + sequenceA (This a) = pure $ This a + sequenceA (That x) = That <$> x + sequenceA (These a x) = These a <$> x + +instance Bifunctor These where + bimap f _ (This a ) = This (f a) + bimap _ g (That x) = That (g x) + bimap f g (These a x) = These (f a) (g x) + +instance Bifoldable These where + bifold = these id id mappend + bifoldr f g z = these (`f` z) (`g` z) (\x y -> x `f` (y `g` z)) + bifoldl f g z = these (z `f`) (z `g`) (\x y -> (z `f` x) `g` y) + +instance Bitraversable These where + bitraverse f _ (This x) = This <$> f x + bitraverse _ g (That x) = That <$> g x + bitraverse f g (These x y) = These <$> f x <*> g y + +instance (Semigroup a) => Applicative (These a) where + pure = That + This a <*> _ = This a + That _ <*> This b = This b + That f <*> That x = That (f x) + That f <*> These b x = These b (f x) + These a _ <*> This b = This (a <> b) + These a f <*> That x = These a (f x) + These a f <*> These b x = These (a <> b) (f x) + + +instance (Semigroup a) => Monad (These a) where + return = pure + This a >>= _ = This a + That x >>= k = k x + These a x >>= k = case k x of + This b -> This (a <> b) + That y -> These a y + These b y -> These (a <> b) y + +------------------------------------------------------------------------------- +-- Data.Functor.Classes +------------------------------------------------------------------------------- + +#ifdef LIFTED_FUNCTOR_CLASSES +instance Eq2 These where + liftEq2 f _ (This a) (This a') = f a a' + liftEq2 _ g (That b) (That b') = g b b' + liftEq2 f g (These a b) (These a' b') = f a a' && g b b' + liftEq2 _ _ _ _ = False + +instance Eq a => Eq1 (These a) where + liftEq = liftEq2 (==) + +instance Ord2 These where + liftCompare2 f _ (This a) (This a') = f a a' + liftCompare2 _ _ (This _) _ = LT + liftCompare2 _ _ _ (This _) = GT + liftCompare2 _ g (That b) (That b') = g b b' + liftCompare2 _ _ (That _) _ = LT + liftCompare2 _ _ _ (That _) = GT + liftCompare2 f g (These a b) (These a' b') = f a a' `mappend` g b b' + +instance Ord a => Ord1 (These a) where + liftCompare = liftCompare2 compare + +instance Show a => Show1 (These a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Show2 These where + liftShowsPrec2 sa _ _sb _ d (This a) = showParen (d > 10) + $ showString "This " + . sa 11 a + liftShowsPrec2 _sa _ sb _ d (That b) = showParen (d > 10) + $ showString "That " + . sb 11 b + liftShowsPrec2 sa _ sb _ d (These a b) = showParen (d > 10) + $ showString "These " + . sa 11 a + . showString " " + . sb 11 b + +instance Read2 These where + liftReadsPrec2 ra _ rb _ d = readParen (d > 10) $ \s -> cons s + where + cons s0 = do + (ident, s1) <- lex s0 + case ident of + "This" -> do + (a, s2) <- ra 11 s1 + return (This a, s2) + "That" -> do + (b, s2) <- rb 11 s1 + return (That b, s2) + "These" -> do + (a, s2) <- ra 11 s1 + (b, s3) <- rb 11 s2 + return (These a b, s3) + _ -> [] + +instance Read a => Read1 (These a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +#else +instance Eq a => Eq1 (These a) where eq1 = (==) +instance Ord a => Ord1 (These a) where compare1 = compare +instance Show a => Show1 (These a) where showsPrec1 = showsPrec +instance Read a => Read1 (These a) where readsPrec1 = readsPrec +#endif + +------------------------------------------------------------------------------- +-- assoc +------------------------------------------------------------------------------- + +#ifdef MIN_VERSION_assoc +instance Swap These where + swap (This a) = That a + swap (That b) = This b + swap (These a b) = These b a + +instance Assoc These where + assoc (This (This a)) = This a + assoc (This (That b)) = That (This b) + assoc (That c) = That (That c) + assoc (These (That b) c) = That (These b c) + assoc (This (These a b)) = These a (This b) + assoc (These (This a) c) = These a (That c) + assoc (These (These a b) c) = These a (These b c) + + unassoc (This a) = This (This a) + unassoc (That (This b)) = This (That b) + unassoc (That (That c)) = That c + unassoc (That (These b c)) = These (That b) c + unassoc (These a (This b)) = This (These a b) + unassoc (These a (That c)) = These (This a) c + unassoc (These a (These b c)) = These (These a b) c +#endif + +------------------------------------------------------------------------------- +-- deepseq +------------------------------------------------------------------------------- + +instance (NFData a, NFData b) => NFData (These a b) where + rnf (This a) = rnf a + rnf (That b) = rnf b + rnf (These a b) = rnf a `seq` rnf b + +#if MIN_VERSION_deepseq(1,4,3) +instance NFData a => NFData1 (These a) where + liftRnf _rnfB (This a) = rnf a + liftRnf rnfB (That b) = rnfB b + liftRnf rnfB (These a b) = rnf a `seq` rnfB b + +instance NFData2 These where + liftRnf2 rnfA _rnfB (This a) = rnfA a + liftRnf2 _rnfA rnfB (That b) = rnfB b + liftRnf2 rnfA rnfB (These a b) = rnfA a `seq` rnfB b +#endif + +------------------------------------------------------------------------------- +-- binary +------------------------------------------------------------------------------- + +instance (Binary a, Binary b) => Binary (These a b) where + put = put . toLazy + get = toStrict <$> get + +------------------------------------------------------------------------------- +-- hashable +------------------------------------------------------------------------------- + +instance (Hashable a, Hashable b) => Hashable (These a b) where + hashWithSalt salt (This a) = + salt `hashWithSalt` (0 :: Int) `hashWithSalt` a + hashWithSalt salt (That b) = + salt `hashWithSalt` (1 :: Int) `hashWithSalt` b + hashWithSalt salt (These a b) = + salt `hashWithSalt` (2 :: Int) `hashWithSalt` a `hashWithSalt` b + +instance Hashable a => Hashable1 (These a) where + liftHashWithSalt _hashB salt (This a) = + salt `hashWithSalt` (0 :: Int) `hashWithSalt` a + liftHashWithSalt hashB salt (That b) = + (salt `hashWithSalt` (1 :: Int)) `hashB` b + liftHashWithSalt hashB salt (These a b) = + (salt `hashWithSalt` (2 :: Int) `hashWithSalt` a) `hashB` b + +instance Hashable2 These where + liftHashWithSalt2 hashA _hashB salt (This a) = + (salt `hashWithSalt` (0 :: Int)) `hashA` a + liftHashWithSalt2 _hashA hashB salt (That b) = + (salt `hashWithSalt` (1 :: Int)) `hashB` b + liftHashWithSalt2 hashA hashB salt (These a b) = + (salt `hashWithSalt` (2 :: Int)) `hashA` a `hashB` b diff --git a/src/Data/Strict/Tuple.hs b/src/Data/Strict/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Strict/Tuple.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} +#ifndef __HADDOCK__ +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE TypeOperators #-} +#endif +#endif + +#if MIN_VERSION_base(4,9,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#else +#if MIN_VERSION_transformers(0,5,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#else +#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) +#define LIFTED_FUNCTOR_CLASSES 1 +#endif +#endif +#endif + +----------------------------------------------------------------------------- +-- | +-- +-- The strict variant of the standard Haskell pairs and the corresponding +-- variants of the functions from "Data.Tuple". +-- +-- Note that unlike regular Haskell pairs, @(x :*: _|_) = (_|_ :*: y) = _|_@ +-- +----------------------------------------------------------------------------- + +module Data.Strict.Tuple ( + Pair(..) +#ifndef __HADDOCK__ +#ifdef __GLASGOW_HASKELL__ + , (:!:) +#endif +#endif + , fst + , snd + , curry + , uncurry + , Data.Strict.Tuple.swap -- disambiguate + , zip + , unzip +) where + +-- import parts explicitly, helps with compatibility +import Prelude (Functor (..), Eq (..), Ord (..), Show (..), Read (..), (.), Bounded, map, ($) + , (&&), showParen, showString, readParen, lex, return) +import Control.Applicative ((<$>), (<*>)) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Foldable (Foldable (..)) +import Data.Traversable (Traversable (..)) + +-- Lazy variants +import qualified Prelude as L + +import Control.DeepSeq (NFData (..)) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Binary (Binary (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Hashable (Hashable(..)) +import Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..)) +import Data.Ix (Ix (..)) +import GHC.Generics (Generic) +import Data.Data (Data (..), Typeable) + +#if __GLASGOW_HASKELL__ >= 706 +import GHC.Generics (Generic1) +#endif + +#if MIN_VERSION_deepseq(1,4,3) +import Control.DeepSeq (NFData1 (..), NFData2 (..)) +#endif + +#ifdef MIN_VERSION_assoc +import Data.Bifunctor.Assoc (Assoc (..)) +import Data.Bifunctor.Swap (Swap (..)) +#endif + +#ifdef LIFTED_FUNCTOR_CLASSES +import Data.Functor.Classes + (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Read1 (..), Read2 (..), + Show1 (..), Show2 (..)) +#else +import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) +#endif + +#if __HADDOCK__ +import Data.Tuple () +#endif + +-- $setup +-- >>> import Prelude (Char, String) +-- >>> import Data.Functor.Classes (readsPrec2) + +infix 2 :!: + +-- | The type of strict pairs. +data Pair a b = !a :!: !b + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Bounded, Ix +#if __GLASGOW_HASKELL__ >= 706 + , Generic1 +#endif + ) + +#ifndef __HADDOCK__ +#ifdef __GLASGOW_HASKELL__ +-- This gives a nicer syntax for the type but only works in GHC for now. +type (:!:) = Pair +#endif +#endif + +toStrict :: (a, b) -> Pair a b +toStrict (a, b) = a :!: b + +toLazy :: Pair a b -> (a, b) +toLazy (a :!: b) = (a, b) + +-- | Extract the first component of a strict pair. +fst :: Pair a b -> a +fst (x :!: _) = x + +-- | Extract the second component of a strict pair. +snd :: Pair a b -> b +snd (_ :!: y) = y + +-- | Curry a function on strict pairs. +curry :: (Pair a b -> c) -> a -> b -> c +curry f x y = f (x :!: y) + +-- | Convert a curried function to a function on strict pairs. +uncurry :: (a -> b -> c) -> Pair a b -> c +uncurry f (x :!: y) = f x y + +-- | Analagous to 'L.swap' from "Data.Tuple" +swap :: Pair a b -> Pair b a +swap (a :!: b) = b :!: a + +-- | Zip for strict pairs (defined with zipWith). +zip :: [a] -> [b] -> [Pair a b] +zip x y = L.zipWith (:!:) x y + +-- | Unzip for stict pairs into a (lazy) pair of lists. +unzip :: [Pair a b] -> ([a], [b]) +unzip x = ( map fst x + , map snd x + ) + +-- Instances +------------ + +instance Functor (Pair e) where + fmap f = toStrict . fmap f . toLazy + +instance Foldable (Pair e) where + foldMap f (_ :!: x) = f x + +instance Traversable (Pair e) where + traverse f (e :!: x) = (:!:) e <$> f x + +instance (Semigroup a, Semigroup b) => Semigroup (Pair a b) where + (x1 :!: y1) <> (x2 :!: y2) = (x1 <> x2) :!: (y1 <> y2) + +instance (Monoid a, Monoid b) => Monoid (Pair a b) where + mempty = mempty :!: mempty + (x1 :!: y1) `mappend` (x2 :!: y2) = (x1 `mappend` x2) :!: (y1 `mappend` y2) + +-- deepseq +instance (NFData a, NFData b) => NFData (Pair a b) where + rnf = rnf . toLazy + +#if MIN_VERSION_deepseq(1,4,3) +instance (NFData a) => NFData1 (Pair a) where + liftRnf rnfA = liftRnf rnfA . toLazy + +instance NFData2 Pair where + liftRnf2 rnfA rnfB = liftRnf2 rnfA rnfB . toLazy +#endif + +-- binary +instance (Binary a, Binary b) => Binary (Pair a b) where + put = put . toLazy + get = toStrict <$> get + +-- bifunctors +instance Bifunctor Pair where + bimap f g (a :!: b) = f a :!: g b + first f (a :!: b) = f a :!: b + second g (a :!: b) = a :!: g b + +instance Bifoldable Pair where + bifold (a :!: b) = a `mappend` b + bifoldMap f g (a :!: b) = f a `mappend` g b + bifoldr f g c (a :!: b) = g b (f a c) + bifoldl f g c (a :!: b) = g (f c a) b + +instance Bitraversable Pair where + bitraverse f g (a :!: b) = (:!:) <$> f a <*> g b + +-- hashable +instance (Hashable a, Hashable b) => Hashable (Pair a b) where + hashWithSalt salt = hashWithSalt salt . toLazy + +instance (Hashable a) => Hashable1 (Pair a) where + liftHashWithSalt hashA salt = liftHashWithSalt hashA salt . toLazy + +instance Hashable2 Pair where + liftHashWithSalt2 hashA hashB salt = liftHashWithSalt2 hashA hashB salt . toLazy + +-- assoc +#ifdef MIN_VERSION_assoc +instance Assoc Pair where + assoc ((a :!: b) :!: c) = (a :!: (b :!: c)) + unassoc (a :!: (b :!: c)) = ((a :!: b) :!: c) + +instance Swap Pair where + swap = Data.Strict.Tuple.swap +#endif + +-- Data.Functor.Classes +#ifdef LIFTED_FUNCTOR_CLASSES +instance Eq2 Pair where + liftEq2 f g (a :!: b) (a' :!: b') = f a a' && g b b' + +instance Eq a => Eq1 (Pair a) where + liftEq = liftEq2 (==) + +instance Ord2 Pair where + liftCompare2 f g (a :!: b) (a' :!: b') = f a a' `mappend` g b b' + +instance Ord a => Ord1 (Pair a) where + liftCompare = liftCompare2 compare + +instance Show a => Show1 (Pair a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Show2 Pair where + liftShowsPrec2 sa _ sb _ d (a :!: b) = showParen (d > 3) + -- prints extra parens + $ sa 3 a + . showString " :!: " + . sb 3 b + +-- | +-- +-- >>> readsPrec2 0 "'a' :!: ('b' :!: 'c')" :: [(Pair Char (Pair Char Char), String)] +-- [('a' :!: ('b' :!: 'c'),"")] +-- +-- >>> readsPrec2 0 "('a' :!: 'b') :!: 'c'" :: [(Pair (Pair Char Char) Char, String)] +-- [(('a' :!: 'b') :!: 'c',"")] +-- +instance Read2 Pair where + liftReadsPrec2 ra _ rb _ d = readParen (d > 3) $ \s -> cons s where + cons s0 = do + (a, s1) <- ra 3 s0 + (":!:", s2) <- lex s1 + (b, s3) <- rb 3 s2 + return (a :!: b, s3) + + +instance Read a => Read1 (Pair a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +#else +instance Eq a => Eq1 (Pair a) where eq1 = (==) +instance Ord a => Ord1 (Pair a) where compare1 = compare +instance Show a => Show1 (Pair a) where showsPrec1 = showsPrec +instance Read a => Read1 (Pair a) where readsPrec1 = readsPrec +#endif diff --git a/src/System/IO/Strict.hs b/src/System/IO/Strict.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Strict.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.IO.Strict +-- Copyright : (c) Don Stewart 2007 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : dons@galois.com +-- Stability : stable +-- Portability : portable +-- +-- The standard IO input functions using strict IO. +-- +----------------------------------------------------------------------------- + +module System.IO.Strict ( + + -- * Strict Handle IO + hGetContents, -- :: Handle -> IO [Char] + + -- * Strict String IO wrappers + getContents, -- :: IO String + readFile, -- :: FilePath -> IO String + interact -- :: (String -> String) -> IO () + + ) where + +import Prelude ( String, (>>=), seq, return, (.), (=<<), FilePath, length) +import System.IO (IO) +import qualified System.IO as IO + +-- ----------------------------------------------------------------------------- +-- Strict hGetContents + +-- | Computation 'hGetContents' @hdl@ returns the list of characters +-- corresponding to the unread portion of the channel or file managed +-- by @hdl@, which is immediate closed. +-- +-- Items are read strictly from the input Handle. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. + +hGetContents :: IO.Handle -> IO.IO String +hGetContents h = IO.hGetContents h >>= \s -> length s `seq` return s + +-- ----------------------------------------------------------------------------- +-- Standard IO + +-- | The 'getContents' operation returns all user input as a single string, +-- which is read stirctly (same as 'hGetContents' 'stdin'). + +getContents :: IO String +getContents = hGetContents IO.stdin +{-# INLINE getContents #-} + +-- | The 'interact' function takes a function of type @String->String@ +-- as its argument. The entire input from the standard input device is +-- passed to this function as its argument, and the resulting string is +-- output on the standard output device. + +interact :: (String -> String) -> IO () +interact f = IO.putStr . f =<< getContents +{-# INLINE interact #-} + +-- | The 'readFile' function reads a file and +-- returns the contents of the file as a string. +-- The file is read strictly, as with 'getContents'. + +readFile :: FilePath -> IO String +readFile name = IO.openFile name IO.ReadMode >>= hGetContents +{-# INLINE readFile #-} diff --git a/strict.cabal b/strict.cabal --- a/strict.cabal +++ b/strict.cabal @@ -1,32 +1,117 @@ Name: strict -Version: 0.3.2 +Version: 0.4 Synopsis: Strict data types and String IO. Category: Data, System Description: - This package provides strict versions of some standard Haskell data - types (pairs, Maybe and Either). It also contains strict IO - operations. + This package provides strict versions of some standard Haskell data + types (pairs, Maybe and Either). It also contains strict IO operations. + . + It is common knowledge that lazy datastructures can lead to space-leaks. + This problem is particularly prominent, when using lazy datastructures to + store the state of a long-running application in memory. One common + solution to this problem is to use @seq@ and its variants in every piece of + code that updates your state. However a much easier solution is to use + fully strict types to store such state values. By \"fully strict types\" we + mean types for whose values it holds that, if they are in weak-head normal + form, then they are also in normal form. Intuitively, this means that + values of fully strict types cannot contain unevaluated thunks. + . + To define a fully strict datatype, one typically uses the following recipe. + . + 1. Make all fields of every constructor strict; i.e., add a bang to + all fields. + . + 2. Use only strict types for the fields of the constructors. + . + The second requirement is problematic as it rules out the use of + the standard Haskell 'Maybe', 'Either', and pair types. This library + solves this problem by providing strict variants of these types and their + corresponding standard support functions and type-class instances. + . + Note that this library does currently not provide fully strict lists. + They can be added if they are really required. However, in many cases one + probably wants to use unboxed or strict boxed vectors from the 'vector' + library () instead of strict + lists. Moreover, instead of @String@s one probably wants to use strict + @Text@ values from the @text@ library + (). + . + This library comes with batteries included; i.e., mirror functions and + instances of the lazy versions in @base@. It also includes instances for + type-classes from the @deepseq@, @binary@, and @hashable@ packages. License: BSD3 License-File: LICENSE Author: Roman Leshchinskiy -Maintainer: Don Stewart -Copyright: (c) 2006-2007 by Roman Leshchinskiy -Homepage: http://www.cse.unsw.edu.au/~rl/code/strict.html -Cabal-Version: >= 1.2 + Simon Meier +Maintainer: Don Stewart , + Bas van Dijk , + Oleg Grenrus , + Simon Meier , + Ximin Luo +Copyright: (c) 2006-2008 by Roman Leshchinskiy + (c) 2013-2014 by Simon Meier +Homepage: https://github.com/haskell-strict/strict +Cabal-Version: >= 1.10 Build-type: Simple +extra-source-files: CHANGELOG.md +tested-with: + GHC ==7.4.2 + || ==7.6.3 + || ==7.8.4 + || ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.3 + || ==8.10.1 -flag split-base +flag assoc + description: Build with assoc dependency + manual: True + default: True library - if flag(split-base) - build-depends: base >= 3, array - else - build-depends: base < 3 + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + + build-depends: + base >= 4.5.0.0 && < 5 + , binary >= 0.5.1.0 && < 0.9 + , bytestring >= 0.9.2.1 && < 0.11 + , deepseq >= 1.3.0.0 && < 1.5 + , hashable >= 1.2.7.0 && < 1.4 + , text >= 1.2.3.0 && < 1.3 + , these >= 1.1.1.1 && < 1.2 + , transformers >= 0.3.0.0 && < 0.6 + , ghc-prim + + if !impl(ghc >= 8.0) + build-depends: + semigroups >= 0.18.5 && < 0.20 + + if !impl(ghc >=8.0) + build-depends: + semigroups >= 0.18.5 && < 0.20 + , transformers-compat >= 0.6.5 && < 0.7 + + -- Ensure Data.Functor.Classes is always available + if impl(ghc >= 7.10) + build-depends: transformers >= 0.4.2.0 + + if !impl(ghc >= 8.2) + build-depends: + bifunctors >= 5.5.2 && < 5.6 + + if flag(assoc) + build-depends: assoc >= 1.0.1 && < 1.1 + exposed-modules: - Data.Strict.Tuple - Data.Strict.Maybe - Data.Strict.Either - Data.Strict - System.IO.Strict - ghc-options: -Wall - extensions: CPP + Data.Strict + Data.Strict.Classes + Data.Strict.These + Data.Strict.Tuple + Data.Strict.Maybe + Data.Strict.Either + System.IO.Strict