strict 0.3.2 → 0.4
raw patch · 14 files changed
+1529/−310 lines, 14 filesdep +assocdep +bifunctorsdep +binarydep −arraydep ~basenew-uploader
Dependencies added: assoc, bifunctors, binary, bytestring, deepseq, ghc-prim, hashable, semigroups, text, these, transformers, transformers-compat
Dependencies removed: array
Dependency ranges changed: base
Files
- CHANGELOG.md +9/−0
- Data/Strict.hs +0/−24
- Data/Strict/Either.hs +0/−64
- Data/Strict/Maybe.hs +0/−68
- Data/Strict/Tuple.hs +0/−62
- System/IO/Strict.hs +0/−72
- src/Data/Strict.hs +16/−0
- src/Data/Strict/Classes.hs +99/−0
- src/Data/Strict/Either.hs +279/−0
- src/Data/Strict/Maybe.hs +241/−0
- src/Data/Strict/These.hs +434/−0
- src/Data/Strict/Tuple.hs +273/−0
- src/System/IO/Strict.hs +73/−0
- strict.cabal +105/−20
+ CHANGELOG.md view
@@ -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
− Data/Strict.hs
@@ -1,24 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Strict--- Copyright : (c) 2006-2007 Roman Leshchinskiy--- License : BSD-style (see the file LICENSE)--- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au>--- 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-
− Data/Strict/Either.hs
@@ -1,64 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Strict.Either--- Copyright : (c) 2006-2007 Roman Leshchinskiy--- License : BSD-style (see the file LICENSE)--- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au>--- 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"---
− Data/Strict/Maybe.hs
@@ -1,68 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Strict.Maybe--- Copyright : (c) 2006-2007 Roman Leshchinskiy--- License : BSD-style (see the file LICENSE)--- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au>--- 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-
− Data/Strict/Tuple.hs
@@ -1,62 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Strict.Tuple--- Copyright : (c) 2006-2007 Roman Leshchinskiy--- License : BSD-style (see the file LICENSE)--- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au>--- 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-
− System/IO/Strict.hs
@@ -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 #-}
+ src/Data/Strict.hs view
@@ -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
+ src/Data/Strict/Classes.hs view
@@ -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
+ src/Data/Strict/Either.hs view
@@ -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
+ src/Data/Strict/Maybe.hs view
@@ -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
+ src/Data/Strict/These.hs view
@@ -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
+ src/Data/Strict/Tuple.hs view
@@ -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
+ src/System/IO/Strict.hs view
@@ -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 #-}
strict.cabal view
@@ -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 (<http://hackage.haskell.org/package/vector>) instead of strict+ lists. Moreover, instead of @String@s one probably wants to use strict+ @Text@ values from the @text@ library+ (<http://hackage.haskell.org/package/text>).+ .+ 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 <rl@cse.unsw.edu.au>-Maintainer: Don Stewart <dons@galois.com>-Copyright: (c) 2006-2007 by Roman Leshchinskiy-Homepage: http://www.cse.unsw.edu.au/~rl/code/strict.html-Cabal-Version: >= 1.2+ Simon Meier <iridcode@gmail.com>+Maintainer: Don Stewart <dons@galois.com>,+ Bas van Dijk <v.dijk.bas@gmail.com>,+ Oleg Grenrus <oleg.grenrus@iki.fi>,+ Simon Meier <iridcode@gmail.com>,+ Ximin Luo <infinity0@pwned.gg>+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