packages feed

strict-data 0.1.1.0 → 0.2.0.2

raw patch · 22 files changed

+3102/−26 lines, 22 filesdep +HTFdep +QuickCheckdep +containers

Dependencies added: HTF, QuickCheck, containers, doctest, exceptions, fail, hashable, monad-control, mtl, pretty, resourcet, strict, strict-data, text, transformers, transformers-base, unordered-containers, util-plus, vector, vector-algorithms

Files

LICENSE view
@@ -1,4 +1,5 @@ Copyright Alexander Thiemann (c) 2016+Copyright factis research GmbH (c) 2017  All rights reserved.
README.md view
@@ -1,5 +1,13 @@ # Various strict data structures -This package currently contains strict data structures and usefuly instance for:+[![CircleCI](https://circleci.com/gh/factisresearch/opensource-mono.svg?style=svg)](https://circleci.com/gh/factisresearch/opensource-mono) +This package currently contains strict data structures and useful instances for:++* `Data.Choice` to replace `Data.Either`+* `Data.Fail` for a sane error monad * `Data.Option` to replace `Data.Maybe`+* `Data.StrictList` to replace `Data.List`+* `Data.StrictTuple` to replace tuples+* `Data.StrictVector` and `Data.StrictVector.Mutable` to replace `Data.Vector`+  and `Data.Vector.Mutable`
+ src/Data/Choice.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Choice where++import Control.DeepSeq (NFData(..))+import Data.Bifunctor+import Data.Data+import Data.Hashable+import Safe.Plus+import Test.QuickCheck++-- | 'Choice' is a version of 'Either' that is strict on both the 'Left' side (called 'This')+-- and the 'Right' side (called 'That').+--+-- Note: 'Choice' is not used as an error monad. Use 'Data.Fail.Fail' for that.+data Choice a b+    = This !a+    | That !b+    deriving (Eq, Ord, Read, Show, Typeable, Data)++-- | 'Choice''s version of 'either'+choice :: (a -> c) -> (b -> c) -> Choice a b -> c+choice fa fb = mergeChoice . bimap fa fb++-- |+-- >>> this (This "foo") :: Maybe String+-- Just "foo"+--+-- >>> this (That "bar") :: Maybe String+-- Nothing+this :: Monad m => Choice a b -> m a+this (This a) = return a+this _ = safeFail "This is a that"++-- |+-- >>> that (This "foo") :: Maybe String+-- Nothing+--+-- >>> that (That "bar") :: Maybe String+-- Just "bar"+that :: Monad m => Choice a b -> m b+that (That a) = return a+that _ = safeFail "That is a this"++-- |+-- >>> these [This "foo", This "bar", That "baz", This "quux"]+-- ["foo","bar","quux"]+these :: [Choice a b] -> [a]+these = concatMap this++-- |+-- >>> those [This "foo", This "bar", That "baz", This "quux"]+-- ["baz"]+those :: [Choice a b] -> [b]+those = concatMap that++-- |+-- >>> eitherToChoice (Left 1)+-- This 1+--+-- >>> eitherToChoice (Right 5)+-- That 5+eitherToChoice :: Either a b -> Choice a b+eitherToChoice = either This That++-- |+-- >>> mergeChoice (This 5 :: Choice Int Int)+-- 5+--+-- >>> mergeChoice (That 'c' :: Choice Char Char)+-- 'c'+mergeChoice :: Choice a a -> a+mergeChoice x =+    case x of+      This y -> y+      That y -> y++instance Bifunctor Choice where+    bimap f g x =+        case x of+          This a -> This (f a)+          That b -> That (g b)++instance (Hashable a, Hashable b) => Hashable (Choice a b) where+    hashWithSalt s (This x) = s `hashWithSalt` (0 :: Int) `hashWithSalt` x+    hashWithSalt s (That x) = s `hashWithSalt` (1 :: Int) `hashWithSalt` x++instance Applicative (Choice e) where+    pure         = That+    This e <*> _ = This e+    That f <*> r = fmap f r++instance Functor (Choice a) where+    fmap = second++instance Monad (Choice e) where+    return = That+    This l >>= _ = This l+    That r >>= k = k r++instance (Arbitrary a, Arbitrary b) => Arbitrary (Choice a b) where+    arbitrary =+        do bool <- arbitrary+           if bool+             then fmap This arbitrary+             else fmap That arbitrary++    shrink (This a) = map This $ shrink a+    shrink (That b) = map That $ shrink b++instance (NFData a, NFData b) => NFData (Choice a b) where+    rnf (This x)  = rnf x+    rnf (That y) = rnf y
+ src/Data/Fail.hs view
@@ -0,0 +1,400 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Data.Fail+    ( Fail(..), pattern Fail, isFail, isOk+    , FailT(FailT), runFailT, FIO+    , failEitherStr, failEitherShow, failEitherText+    , runExceptTFail, failInM, failInM', failInM''+    , failToEither, failMaybe, failToMaybe, mapFail+    , failSwitch, fromFail+    , MonadFailure(..)+    , failForIOException, catFails+    , eitherToError, errorToEither, liftError, errorToDefault, errorToMaybe, maybeToError, runError+    , runExceptTorFail, maybeToFail, eitherToFail+    , fromFailString, partitionFails+    , safeFromOk+    , Control.Monad.Fail.MonadFail+) where+++import Data.Fail.Types++import Control.Applicative (Alternative(..))+import Control.Exception (ErrorCall(..), IOException, catch)+import Control.Monad (MonadPlus(..))+import Control.Monad.Base (MonadBase (..), liftBaseDefault)+import Control.Monad.Catch (MonadThrow (..))+import Control.Monad.Except (ExceptT, runExceptT, MonadError(..))+import Control.Monad.Fail (MonadFail)+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Identity (runIdentity)+import Control.Monad.Reader (ReaderT(..))+import Control.Monad.State (MonadState(..))+import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource (MonadResource (..))+import Control.Monad.Writer (MonadWriter(..))+import GHC.Stack+import GHC.Stack.Plus+import Safe.Plus+import Test.QuickCheck+import qualified Control.Monad.Fail+import qualified Data.Text as T++instance Arbitrary a => Arbitrary (Fail a) where+    arbitrary =+        oneof+        [ Ok <$> arbitrary+        , Fail <$> arbitrary+        ]++instance MonadThrow m => MonadThrow (FailT m) where+    throwM = FailT . throwM++instance MonadBase b m => MonadBase b (FailT m) where+    liftBase = liftBaseDefault++instance MonadBaseControl b m => MonadBaseControl b (FailT m) where+    type StM (FailT m) a = ComposeSt FailT m a+    liftBaseWith = defaultLiftBaseWith+    restoreM = defaultRestoreM++instance MonadTransControl FailT where+    type StT FailT a = Fail a+    liftWith f = FailT $ return <$> f runFailT+    restoreT = FailT++instance Monad m => MonadError String (FailT m) where+    throwError = throwFailT+    catchError = catchFailT++instance MonadTrans FailT where+    lift m =+        FailT $+        do a <- m+           return (Ok a)++instance MonadIO m => MonadIO (FailT m) where+    liftIO io = FailT $ fmap Ok (liftIO io)++instance MonadState s m => MonadState s (FailT m) where+    get = lift get+    put = lift . put++instance MonadResource m => MonadResource (FailT m) where+    liftResourceT = FailT . fmap Ok . liftResourceT++instance MonadWriter w m => MonadWriter w (FailT m) where+    tell = lift . tell+    listen =+        mapFailT $ \m ->+        do (a, w) <- listen m+           return $! fmap (\r -> (r, w)) a+    pass =+        mapFailT $ \m ->+        pass $+        do a <- m+           return $!+               case a of+                 Err l -> (Err l, id)+                 Ok (r, f) -> (Ok r, f)++mapFailT :: (m (Fail a) -> n (Fail b)) -> FailT m a -> FailT n b+mapFailT f = FailT . f . runFailT++throwFailT :: Monad m => String -> FailT m a+throwFailT l = FailT $ return (Fail l)++catchFailT :: Monad m => FailT m a -> (String -> FailT m a) -> FailT m a+m `catchFailT` h =+    FailT $+    do a <- runFailT m+       case a of+         Err l -> runFailT (h $ T.unpack l)+         Ok r -> return (Ok r)++isFail :: Fail a -> Bool+isFail (Err _) = True+isFail (Ok _) = False++isOk :: Fail a -> Bool+isOk = not . isFail++instance Monad Fail where+    return = Ok+    {-# INLINE return #-}+    fail = Control.Monad.Fail.fail+    {-# INLINE fail #-}+    (>>=) = failBind+    {-# INLINE (>>=) #-}++instance Control.Monad.Fail.MonadFail Fail where+    fail = Fail+    {-# INLINE fail #-}++instance MonadPlus Fail where+    mzero = failZero+    mplus = failPlus++instance Applicative Fail where+    pure = Ok+    (<*>) = failAp++instance Alternative Fail where+    empty = failZero+    (<|>) = failPlus++instance MonadFix Fail where+    mfix f = let a = f (unOk a) in a+        where+          unOk (Ok x) = x+          unOk (Err msg) = safeError ("mfix failed: " ++ T.unpack msg)++instance MonadFix m => MonadFix (FailT m) where+    mfix f =+        FailT $ mfix $ \a -> runFailT $ f $+        case a of+          Ok r -> r+          Err msg -> safeError ("FailT.mfix failed: " ++ T.unpack msg)++instance Monad m => Monad (FailT m) where+    return = returnFailT+    fail = Control.Monad.Fail.fail+    (>>=) = bindFailT++instance Monad m => Control.Monad.Fail.MonadFail (FailT m) where+    fail = FailT . return . Fail++instance (Functor m, Monad m) => Applicative (FailT m) where+    pure = FailT . return . Ok+    FailT f <*> FailT v =+        FailT $+            do mf <- f+               case mf of+                 Err msg -> return (Err msg)+                 Ok k ->+                     do mv <- v+                        case mv of+                          Err msg -> return (Err msg)+                          Ok x -> return (Ok (k x))++instance Monad m => Alternative (FailT m) where+    empty = FailT $ return failZero+    FailT f <|> FailT g =+        FailT $+            do mf <- f+               mg <- g+               return $ mf `failPlus` mg++instance Monad m => MonadPlus (FailT m) where+    mzero = empty+    mplus = (<|>)++failBind :: Fail a -> (a -> Fail b) -> Fail b+failBind ma f =+    case ma of+      Ok x -> {-# SCC "Fail/>>=/f" #-} (f x)+      -- is there a better way to avoid allocations?+      Err x -> {-# SCC "Fail/>>=/Fail" #-} (Err x)+{-# INLINE failBind #-}++failAp :: Fail (a -> b) -> Fail a -> Fail b+failAp (Ok f) (Ok a) = Ok (f a)+failAp (Err msg) _ = Err msg+failAp _ (Err msg) = Err msg+{-# INLINE failAp #-}++failZero :: Fail a+failZero = Fail "mzero"+{-# INLINE failZero #-}++failPlus :: Fail a -> Fail a -> Fail a+failPlus x@(Ok _) _ = x+failPlus _ x = x+{-# INLINE failPlus #-}++failSwitch :: (String -> c) -> (a -> c) -> Fail a -> c+failSwitch _ g (Ok x) = g x+failSwitch f _ (Err x) = f (T.unpack x)+{-# INLINE failSwitch #-}++{-# INLINE runFailT #-}+runFailT :: FailT m a -> m (Fail a)+runFailT = unFailT++{-# INLINE returnFailT #-}+returnFailT :: Monad m => a -> FailT m a+returnFailT = FailT . return . Ok++{-# INLINE bindFailT #-}+bindFailT :: Monad m => FailT m a -> (a -> FailT m b) -> FailT m b+bindFailT (FailT action) f =+    FailT $+    do mx <- action+       case mx of+         Ok x -> unFailT (f x)+         Err m -> return (Err m)++instance MonadError String Fail where+    throwError             = Fail+    Err l `catchError` h = h (T.unpack l)+    Ok r `catchError` _    = Ok r++failMaybe :: String -> Maybe a -> Fail a+failMaybe _ (Just x) = Ok x+failMaybe msg Nothing = Fail msg++failEitherStr :: Either String a -> Fail a+failEitherStr = either Fail Ok++failEitherText :: Either T.Text a -> Fail a+failEitherText = either (Fail . T.unpack) Ok++failEitherShow :: Show a => Either a b -> Fail b+failEitherShow e =+    case e of+      Left err -> Fail $ show err+      Right val -> Ok val++runExceptTFail :: Monad m => ExceptT String m a -> m (Fail a)+runExceptTFail err =+    do eith <- runExceptT err+       case eith of+         Left err -> return $ Fail err+         Right x -> return $ Ok x++class Control.Monad.Fail.MonadFail m => MonadFailure m where+    catchFailure :: m a -> (String -> m a) -> m a++instance MonadFailure Maybe where+    Nothing `catchFailure` hdl = hdl "Failed in Maybe."+    ok `catchFailure` _ = ok++instance MonadFailure IO where+    catchFailure action hdl = action `catch` \(ErrorCall s) -> hdl s++instance MonadFailure Fail where+    ok@(Ok _) `catchFailure` _ =  ok+    Err msg `catchFailure` hdl = hdl (T.unpack msg)++instance Monad m => MonadFailure (FailT m) where+    FailT action `catchFailure` hdl =+        FailT $+        do result <- action+           case result of+             Err msg -> unFailT (hdl $ T.unpack msg)+             Ok _ -> return result++instance (MonadFail (ReaderT r m), MonadFailure m) => MonadFailure (ReaderT r m) where+    action `catchFailure` handler =+        ReaderT $ \r ->+        runReaderT action r `catchFailure` \msg -> runReaderT (handler msg) r++failInM :: Monad m => Fail a -> m a+failInM f = failInM' f id++failInM' :: Monad m => Fail a -> (String -> String) -> m a+failInM' f h =+    case f of+      Ok x -> return x+      Err msg -> fail (h $ T.unpack msg)++failInM'' :: Monad m => String -> Fail a -> m a+failInM'' what = flip failInM' (("Failed to " ++ what ++ ":")++)++mapFail :: (String -> String) -> Fail a -> Fail a+mapFail f x =+    case x of+      Ok _ -> x+      Err msg -> Fail (f $ T.unpack msg)++failToEither :: Fail a -> Either String a+failToEither (Ok x) = Right x+failToEither (Err x) = Left (T.unpack x)++failToMaybe :: Fail a -> Maybe a+failToMaybe (Ok x) = Just x+failToMaybe _ = Nothing++failForIOException :: IO a -> IO (Fail a)+failForIOException action =+    catch (Ok <$> action) (\(exc::IOException) -> return (Fail (show exc)))++catFails :: [Fail a] -> [a]+catFails [] = []+catFails ((Err _):xs) = catFails xs+catFails ((Ok a):xs) = a:(catFails xs)++fromFail :: (String -> a) -> Fail a -> a+fromFail f = failSwitch f id++fromFailString :: Fail a -> Maybe String+fromFailString f =+    case f of+      Ok _ -> Nothing+      Err str -> Just (T.unpack str)++runError :: forall a. (forall m. Monad m => m a) -> Either String a+runError x = runIdentity (runExceptT x)++partitionFails :: [Fail a] -> ([a], [String])+partitionFails l = go l ([], [])+    where+      go l (good, bad) =+          case l of+            [] ->+                (reverse good, reverse bad)+            (Ok x : rest) ->+                go rest (x : good, bad)+            (Err s : rest) ->+                go rest (good, T.unpack s : bad)++eitherToError :: MonadError e m => Either e a -> m a+eitherToError = either throwError return++errorToEither :: MonadError e m => m a -> m (Either e a)+errorToEither m = catchError (Right <$> m) (return . Left)++errorToDefault :: MonadError e m => a -> m a -> m a+errorToDefault a ma = catchError ma (\_ -> return a)++liftError :: (MonadError e m, MonadError e m1) => (forall a. m a -> m1 a) -> m a -> m1 a+liftError liftBase action = liftBase (errorToEither action) >>= eitherToError++errorToMaybe :: MonadError e m => m a -> m (Maybe a)+errorToMaybe ma = catchError (Just <$> ma) (\_ -> return Nothing)++maybeToError :: MonadError e m => String -> Maybe a -> m a+maybeToError msg ma =+    case ma of+      Nothing -> safeFail msg+      Just a -> return a++maybeToFail :: Monad m => String -> Maybe a -> m a+maybeToFail msg ma =+    case ma of+         Nothing -> safeFail msg+         Just a -> return a++eitherToFail :: Monad m => Either String a -> m a+eitherToFail = either safeFail return++runExceptTorFail :: (Monad m, Show e) => ExceptT e m a -> m a+runExceptTorFail action =+    do result <- runExceptT action+       either (safeFail . show) return result++safeFromOk :: (HasCallStack) => Fail a -> a+safeFromOk f =+    case f of+      Ok x -> x+      Err msg -> safeError $ callerLocation ++ ": Fail " ++ show msg
+ src/Data/Fail/Types.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+module Data.Fail.Types+    ( Fail(..), pattern Fail+    , FailT(..)+    , FIO+    )+where++import qualified Data.Text as T++pattern Fail :: String -> Fail a+pattern Fail x <- Err (T.unpack -> x) where+    Fail x = Err (T.pack x)++#if (MIN_VERSION_base(4,10,0))+{-# COMPLETE Ok, Fail #-}+#endif++data Fail a+    = Err !T.Text+    | Ok !a+    deriving (Show, Ord, Eq, Functor, Foldable, Traversable)++newtype FailT m a = FailT { unFailT :: m (Fail a) }+    deriving (Functor)++type FIO a = FailT IO a
+ src/Data/Map/Ordered.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE BangPatterns #-}+-- | An ordered, strict map.+--+-- One might think that `Data.Map.Strict` already provides such a data type. This is not correct.+-- `Data.Map.Lazy` and `Data.Map.Strict` use the same, non-strict `Map` datatype.+-- `Data.Map.Strict` just provides functions that evaluate the value argument before inserting it+-- in the Map. The problem is that the typeclass instances of the shared `Map` datatype use the+-- non-strict functions.+module Data.Map.Ordered+    ( OSMap, Map, empty, lookup, insert, delete, fromList, fromListWith, toList, map, mapMaybe+    , lookupLT, lookupGT, lookupLE, lookupGE, lookupM, elemAt+    , singleton, insertWith+    , member, elems, unionWith, difference, union, findWithDefault, size, null, isSubmapOf, unions+    , intersection, foldrWithKey, foldlWithKey, filter, filterWithKey+    , keys, toDescList, updateLookupWithKey+    , deleteLookup, insertLookupWithKey, adjust, assocs, insertWith'+    , alter, differenceWith, updateWithKey, update, mapKeys, insertWithKey, insertWithKey'+    , keysSet+    , maxView, maxViewWithKey, minView, minViewWithKey+    , intersectionWith, fromDistinctAscList+    , toDataMap, fromDataMap, hasKey, hasValue+    )+where++import Control.Arrow (second)+import Control.DeepSeq (NFData(..))+import Data.Coerce+import Data.Data+import Data.Hashable+import Data.List (foldl')+import Data.Maybe (isJust)+import Prelude hiding (map, lookup, null, filter)+import Test.QuickCheck+import qualified Data.Map.Strict as DM+import qualified Data.Set as Set++type Map = OSMap++newtype OSMap k v = OSMap { unOSMap :: DM.Map k v }+    deriving (Eq, Ord, Read, Show, Foldable, NFData, Data)++instance (Hashable k, Hashable v) => Hashable (OSMap k v) where+    hashWithSalt = foldlWithKey updateHash+        where+          updateHash salt k v = hashWithSalt salt k `hashWithSalt` v++instance Functor (OSMap k) where+    {-# INLINE fmap #-}+    fmap = map++instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (OSMap k v) where+    arbitrary = OSMap <$> arbitrary+    shrink = coerce . shrink . unOSMap++instance Traversable (OSMap k) where+    {-# INLINE traverse #-}+    traverse f (OSMap m) =+        fromDataMap <$> DM.traverseWithKey (\_ x -> let y = f x in y) m++instance (Ord k) => Monoid (OSMap k v) where+    mempty = empty+    mconcat = unions+    mappend = union++{-# INLINE fromDataMap #-}+fromDataMap :: DM.Map k v -> OSMap k v+fromDataMap dm = DM.foldr (\a b -> a `seq` b) () dm `seq` OSMap dm++{-# INLINE toDataMap #-}+toDataMap :: OSMap k v -> DM.Map k v+toDataMap = unOSMap++{-# INLINE empty #-}+empty :: OSMap k v+empty = OSMap DM.empty++{-# INLINE member #-}+member :: (Ord k) => k -> OSMap k v -> Bool+member k (OSMap m) = DM.member k m++{-# INLINE lookup #-}+lookup :: (Ord k) => k -> OSMap k v -> Maybe v+lookup k (OSMap hm) = DM.lookup k hm++{-# INLINE lookupM #-}+lookupM :: (Show k, Ord k, Monad m) => k -> OSMap k v -> m v+lookupM k (OSMap hm) =+    case DM.lookup k hm of+      Nothing -> fail ("Could not find " ++ show k ++ " in Map.")+      Just x -> pure x++{-# INLINE lookupLT #-}+lookupLT :: (Ord k) => k -> OSMap k v -> Maybe (k, v)+lookupLT k (OSMap hm) = DM.lookupLT k hm++{-# INLINE lookupGT #-}+lookupGT :: (Ord k) => k -> OSMap k v -> Maybe (k, v)+lookupGT k (OSMap hm) = DM.lookupGT k hm++{-# INLINE lookupLE #-}+lookupLE :: (Ord k) => k -> OSMap k v -> Maybe (k, v)+lookupLE k (OSMap hm) = DM.lookupLE k hm++{-# INLINE lookupGE #-}+lookupGE :: (Ord k) => k -> OSMap k v -> Maybe (k, v)+lookupGE k (OSMap hm) = DM.lookupGE k hm++{-# INLINE insert #-}+insert :: (Ord k) => k -> v -> OSMap k v -> OSMap k v+insert k v (OSMap hm) = OSMap (DM.insert k v hm)++{-# INLINE delete #-}+delete :: (Ord k) => k -> OSMap k v -> OSMap k v+delete k (OSMap hm) = OSMap (DM.delete k hm)++{-# INLINE fromList #-}+fromList :: (Ord k) => [(k,v)] -> OSMap k v+fromList = OSMap . DM.fromList++{-# INLINE fromListWith #-}+fromListWith :: (Ord k) => (v -> v -> v) -> [(k,v)] -> OSMap k v+fromListWith f kvs = OSMap $ DM.fromListWith f kvs++{-# INLINE toList #-}+toList :: OSMap k v -> [(k, v)]+toList (OSMap hm) = DM.toList hm++{-# INLINE toDescList #-}+toDescList :: OSMap k v -> [(k, v)]+toDescList (OSMap hm) = DM.toDescList hm++{-# INLINE map #-}+map :: (v -> v') -> OSMap k v -> OSMap k v'+map f (OSMap m) = OSMap (DM.map f m)++{-# INLINE mapMaybe #-}+mapMaybe :: (v -> Maybe v') -> OSMap k v -> OSMap k v'+mapMaybe f (OSMap m) = OSMap (DM.mapMaybe f m)++{-# INLINE singleton #-}+singleton :: k -> v -> OSMap k v+singleton k v = OSMap (DM.singleton k v)++{-# INLINE insertWith #-}+insertWith :: (Ord k) => (v -> v -> v) -> k -> v -> OSMap k v -> OSMap k v+insertWith f k !v (OSMap hm) = OSMap (DM.insertWith f k v hm)++{-# INLINE elems #-}+elems :: OSMap k v -> [v]+elems = DM.elems . unOSMap++{-# INLINE keys #-}+keys :: OSMap k v -> [k]+keys = DM.keys . unOSMap++{-# INLINE keysSet #-}+keysSet :: OSMap k v -> Set.Set k+keysSet = DM.keysSet . unOSMap++{-# INLINE union #-}+union :: Ord k => OSMap k v -> OSMap k v -> OSMap k v+union (OSMap m1) (OSMap m2) = OSMap (DM.union m1 m2)++{-# INLINABLE unions #-}+unions :: Ord k => [OSMap k v] -> OSMap k v+unions ts = foldl' union empty ts++{-# INLINE unionWith #-}+unionWith :: Ord k => (v -> v -> v) -> OSMap k v -> OSMap k v -> OSMap k v+unionWith f (OSMap m1) (OSMap m2) = OSMap (DM.unionWith f m1 m2)++{-# INLINE difference #-}+difference :: (Ord k) => OSMap k v -> OSMap k w -> OSMap k v+difference (OSMap m1) (OSMap m2) = OSMap (DM.difference m1 m2)++{-# INLINE intersection #-}+intersection :: (Ord k) => OSMap k v -> OSMap k w -> OSMap k v+intersection (OSMap m1) (OSMap m2) = OSMap (DM.intersection m1 m2)++{-# INLINE findWithDefault #-}+findWithDefault :: (Ord k) => a -> k -> OSMap k a -> a+findWithDefault def k (OSMap m) = DM.findWithDefault def k m++{-# INLINE elemAt #-}+elemAt :: Int -> OSMap k a -> (k, a)+elemAt n (OSMap m) = DM.elemAt n m++{-# INLINE size #-}+size :: OSMap k v -> Int+size = DM.size . unOSMap++{-# INLINE null #-}+null :: OSMap k v -> Bool+null = DM.null . unOSMap++{-# INLINE isSubmapOf #-}+isSubmapOf :: (Ord k, Eq a) => OSMap k a -> OSMap k a -> Bool+isSubmapOf (OSMap a) (OSMap b) = DM.isSubmapOf a b++{-# INLINE foldrWithKey #-}+foldrWithKey :: (k -> v -> a -> a) -> a -> OSMap k v -> a+foldrWithKey f a (OSMap hm) = DM.foldrWithKey f a hm++{-# INLINE foldlWithKey #-}+foldlWithKey :: (a -> k -> v -> a) -> a -> OSMap k v -> a+foldlWithKey f a (OSMap hm) = DM.foldlWithKey f a hm++{-# INLINE filter #-}+filter :: (v -> Bool) -> OSMap k v -> OSMap k v+filter f (OSMap m) = OSMap (DM.filter f m)++{-# INLINE filterWithKey #-}+filterWithKey :: (k -> v -> Bool) -> OSMap k v -> OSMap k v+filterWithKey f (OSMap m) = OSMap (DM.filterWithKey f m)++{-# INLINE updateLookupWithKey #-}+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> OSMap k a -> (Maybe a, OSMap k a)+updateLookupWithKey f k (OSMap curMap) =+    let (mv, newMap) = DM.updateLookupWithKey f k curMap+    in (mv, OSMap newMap)++{-# INLINE deleteLookup #-}+deleteLookup :: Ord k => k -> OSMap k v -> (Maybe v, OSMap k v)+deleteLookup = updateLookupWithKey (\_k _v -> Nothing)++{-# INLINE insertLookupWithKey #-}+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> OSMap k a -> (Maybe a, OSMap k a)+insertLookupWithKey f k !newV (OSMap curM) =+    let (mOldV, newM) = DM.insertLookupWithKey f k newV curM+    in (mOldV, OSMap newM)++{-# INLINE adjust #-}+adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a+adjust f k = OSMap . DM.adjust f k . unOSMap++{-# INLINE assocs #-}+assocs :: OSMap k a -> [(k, a)]+assocs = DM.assocs . unOSMap++{-# INLINE insertWith' #-}+insertWith' :: Ord k => (a -> a -> a) -> k -> a -> OSMap k a -> OSMap k a+insertWith' f k !v (OSMap dm) = OSMap (DM.insertWith f k v dm)++{-# INLINE alter #-}+alter :: Ord k => (Maybe a -> Maybe a) -> k -> OSMap k a -> OSMap k a+alter f k (OSMap dm) = OSMap (DM.alter f k dm)++{-# INLINE differenceWith #-}+differenceWith :: Ord k => (a -> b -> Maybe a) -> OSMap k a -> OSMap k b -> OSMap k a+differenceWith f (OSMap dmA) (OSMap dmB) = OSMap (DM.differenceWith f dmA dmB)++{-# INLINE updateWithKey #-}+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> OSMap k a -> OSMap k a+updateWithKey f k (OSMap dm) = OSMap (DM.updateWithKey f k dm)++{-# INLINE update #-}+update :: Ord k => (a -> Maybe a) -> k -> OSMap k a -> OSMap k a+update f k (OSMap dm) = OSMap (DM.update f k dm)++{-# INLINE insertWithKey #-}+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey f k !v (OSMap dm) = OSMap (DM.insertWithKey f k v dm)++{-# INLINE insertWithKey' #-}+insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey' = insertWithKey++{-# INLINE mapKeys #-}+mapKeys :: Ord k2 => (k1 -> k2) -> OSMap k1 a -> OSMap k2 a+mapKeys f (OSMap dm) = OSMap (DM.mapKeys f dm)++{-# INLINE maxView #-}+maxView :: OSMap k a -> Maybe (a, OSMap k a)+maxView (OSMap m) = fmap (second OSMap) (DM.maxView m)++{-# INLINE maxViewWithKey #-}+maxViewWithKey :: OSMap k a -> Maybe ((k, a), OSMap k a)+maxViewWithKey (OSMap m) = fmap (second OSMap) (DM.maxViewWithKey m)++{-# INLINE minView #-}+minView :: OSMap k a -> Maybe (a, OSMap k a)+minView (OSMap m) = fmap (second OSMap) (DM.minView m)++{-# INLINE minViewWithKey #-}+minViewWithKey :: OSMap k a -> Maybe ((k, a), OSMap k a)+minViewWithKey = fmap (second OSMap) . DM.minViewWithKey . unOSMap++{-# INLINE intersectionWith #-}+intersectionWith :: Ord k => (a -> b -> c) -> OSMap k a -> OSMap k b -> OSMap k c+intersectionWith f (OSMap l) (OSMap r) =+    OSMap (DM.intersectionWith f l r)++{-# INLINE fromDistinctAscList #-}+fromDistinctAscList :: [(k,v)] -> OSMap k v+fromDistinctAscList = OSMap . DM.fromDistinctAscList++hasValue :: Int -> OSMap Int Int -> Bool+hasValue v m = any (\(_, x) -> x == v) (toList m)++hasKey :: Int -> OSMap Int Int -> Bool+hasKey k m = isJust (lookup k m)
+ src/Data/Map/Unordered.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | An unordered, strict map.+module Data.Map.Unordered+    ( USMap, Map, empty, lookup, insert, delete, fromList, toList, map, singleton, insertWith+    , member, elems, unionWith, difference, union, findWithDefault, size, null, isSubmapOf+    , intersection, foldrWithKey, foldlWithKey, foldlWithKey', keys, insertLookupWithKey+    , updateLookupWithKey, adjust, deleteLookup, assocs, insertWith', update, alter+    , lookup', unions, toHashMap, fromHashMap, filter, filterWithKey, keysSet, lookupDefault+    , fromListWith, mapMaybe, unionsWith+    )+where+++import Control.DeepSeq (NFData(..))+import Data.Data+import Data.Hashable (Hashable(..))+import Data.Maybe (isJust)+import Prelude hiding (map, lookup, null, filter, pred)+import Test.QuickCheck (Arbitrary(..))+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as Set+import qualified Data.List as List+++type Map = USMap++newtype USMap k v = USMap { unUSMap :: HM.HashMap k v }+    deriving (Eq, Functor, Foldable, Traversable, Typeable, Data, Monoid)++instance (Hashable k, Eq k, Read k, Read v) => Read (USMap k v) where+    readsPrec p s =+        do (l, r) <- readsPrec p s+           return (fromList l, r)++instance (Show k, Show v) => Show (USMap k v) where+    showsPrec p usmap = showsPrec p (toList usmap)++instance (Hashable k, Hashable v) => Hashable (USMap k v) where+    hashWithSalt s (USMap hm) = hashWithSalt s hm++instance (NFData k, NFData v) => NFData (USMap k v) where+    rnf (USMap x) = rnf x++instance (Hashable k, Eq k, Arbitrary k, Arbitrary v) => Arbitrary (USMap k v) where+    arbitrary = fromList <$> arbitrary++toHashMap :: USMap k v -> HM.HashMap k v+toHashMap = unUSMap++fromHashMap :: HM.HashMap k v -> USMap k v+fromHashMap = USMap++empty :: USMap k v+empty = USMap HM.empty++member :: (Eq k, Hashable k) => k -> USMap k v -> Bool+member k (USMap m) =+    case HM.lookup k m of+      Just _ -> True+      Nothing -> False++lookupDefault :: (Eq k, Hashable k) => v -> k -> USMap k v -> v+lookupDefault d k (USMap hm) = HM.lookupDefault d k hm++{-# SPECIALISE lookup :: (Eq k, Hashable k, Show k) => k -> USMap k v -> Maybe v #-}+{-# INLINEABLE lookup #-}+lookup :: (Eq k, Show k, Hashable k, Monad m) => k -> USMap k v -> m v+lookup k (USMap hm) =+    case HM.lookup k hm of+      Nothing -> fail ("Key " ++ show k ++ " not found.")+      Just x -> return x++{-# INLINE lookup' #-}+lookup' :: (Eq k, Hashable k) => k -> USMap k v -> Maybe v+lookup' k (USMap hm) = HM.lookup k hm++insert :: (Eq k, Hashable k) => k -> v -> USMap k v -> USMap k v+insert k v (USMap hm) = USMap (HM.insert k v hm)++delete :: (Eq k, Hashable k) => k -> USMap k v -> USMap k v+delete k (USMap hm) = USMap (HM.delete k hm)++fromList :: (Eq k, Hashable k) => [(k,v)] -> USMap k v+fromList = USMap . HM.fromList++fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> USMap k v+fromListWith f = USMap . HM.fromListWith f++toList :: USMap k v -> [(k, v)]+toList (USMap hm) = HM.toList hm++map :: (v -> v') -> USMap k v -> USMap k v'+map f = USMap . HM.map f . unUSMap++mapMaybe :: (v -> Maybe v') -> USMap k v -> USMap k v'+mapMaybe f = USMap . HM.mapMaybe f . unUSMap++singleton :: Hashable k => k -> v -> USMap k v+singleton k = USMap . HM.singleton k++insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> USMap k v -> USMap k v+insertWith f k v (USMap hm) = USMap (HM.insertWith f k v hm)++elems :: USMap k v -> [v]+elems = HM.elems . unUSMap++keys :: USMap k v -> [k]+keys = HM.keys . unUSMap++keysSet :: (Eq k, Hashable k) => USMap k v -> Set.HashSet k+keysSet = Set.fromList . fmap fst . toList++union :: (Hashable k, Eq k) => USMap k v -> USMap k v -> USMap k v+union (USMap m1) (USMap m2) = USMap (HM.union m1 m2)++unionWith :: (Hashable k, Eq k) => (v -> v -> v) -> USMap k v -> USMap k v -> USMap k v+unionWith f (USMap m1) (USMap m2) = USMap (HM.unionWith f m1 m2)++difference :: (Eq k, Hashable k) => USMap k v -> USMap k w -> USMap k v+difference (USMap m1) (USMap m2) = USMap (HM.difference m1 m2)++intersection :: (Eq k, Hashable k) => USMap k v -> USMap k w -> USMap k v+intersection (USMap m1) (USMap m2) = USMap (HM.intersection m1 m2)++findWithDefault :: (Eq k, Hashable k) => a -> k -> USMap k a -> a+findWithDefault def k (USMap m) =+    case HM.lookup k m of+      Just v -> v+      Nothing -> def++size :: USMap k v -> Int+size = HM.size . unUSMap++null :: USMap k v -> Bool+null = HM.null . unUSMap++isSubmapOf :: (Hashable k, Eq k) => USMap k a -> USMap k a -> Bool+isSubmapOf a b = null (a `difference` b)++foldrWithKey :: (k -> v -> a -> a) -> a -> USMap k v -> a+foldrWithKey f a (USMap hm) = HM.foldrWithKey f a hm++{-# WARNING foldlWithKey "This function is strict.  Better explicitly use USMap.foldlWithKey'" #-}+foldlWithKey :: (a -> k -> v -> a) -> a -> USMap k v -> a+foldlWithKey f a (USMap hm) = HM.foldlWithKey' f a hm++foldlWithKey' :: (a -> k -> v -> a) -> a -> USMap k v -> a+foldlWithKey' f a (USMap hm) = HM.foldlWithKey' f a hm++filterWithKey :: (k -> v -> Bool) -> USMap k v -> USMap k v+filterWithKey pred (USMap hm) = USMap $! HM.filterWithKey pred hm++filter :: (v -> Bool) -> USMap k v -> USMap k v+filter pred (USMap hm) = USMap $! HM.filter pred hm++insertLookupWithKey :: (Eq k, Hashable k) => (k -> a -> a -> a) -> k -> a -> USMap k a+                    -> (Maybe a, USMap k a)+insertLookupWithKey f k newV m =+    case lookup' k m of+      justV@(Just oldV) -> (justV, insert k (f k newV oldV) m)+      nothing@Nothing -> (nothing, insert k newV m)++updateLookupWithKey :: (Eq k, Hashable k) => (k -> a -> Maybe a) -> k -> USMap k a+                    -> (Maybe a, USMap k a)+updateLookupWithKey f k m =+    case lookup' k m of+      Just oldV ->+          case f k oldV of+            justV@(Just newV) -> (justV, insert k newV m)+            Nothing -> (Just oldV, delete k m)+      Nothing -> (Nothing, m)++adjust :: (Eq k, Hashable k) => (a -> a) -> k -> USMap k a -> USMap k a+adjust f k (USMap hm) = USMap (HM.adjust f k hm)++deleteLookup :: (Eq k, Hashable k) => k -> USMap k a -> (Maybe a, USMap k a)+deleteLookup k m = (lookup' k m, delete k m)++{-# INLINE assocs #-}+assocs :: USMap k a -> [(k, a)]+assocs = HM.toList . unUSMap++{-# INLINE insertWith' #-}+insertWith' :: (Eq k, Hashable k) => (a -> a -> a) -> k -> a -> USMap k a -> USMap k a+insertWith' f k !v (USMap hm) = USMap (HM.insertWith f k v hm)++{-# INLINE update #-}+update :: (Eq k, Hashable k) => (a -> Maybe a) -> k -> USMap k a -> USMap k a+update f k um@(USMap hm) =+    case HM.lookup k hm of+      Just curV ->+          case f curV of+            Nothing -> USMap (HM.delete k hm)+            Just newV -> USMap (HM.insert k newV hm)+      Nothing -> um++{-# INLINE alter #-}+alter :: (Eq k, Hashable k) => (Maybe a -> Maybe a) -> k -> USMap k a -> USMap k a+alter f k um@(USMap hm) =+    let mOld = HM.lookup k hm+        mNew = f mOld+    in case mNew of+         Nothing+             | isJust mOld -> USMap (HM.delete k hm)+             | otherwise -> um+         Just new -> USMap (HM.insert k new hm)++unions :: (Hashable k, Eq k) => [USMap k a] -> USMap k a+unions = List.foldl' union empty++unionsWith :: (Hashable k, Eq k) => (a -> a -> a) -> [USMap k a] -> USMap k a+unionsWith f = List.foldl' (unionWith f) empty
src/Data/Option.hs view
@@ -1,25 +1,29 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-} module Data.Option where +import Data.Fail+import Data.StrictList.Types+ import Control.Applicative import Control.DeepSeq import Control.Monad+import Control.Monad.Trans import Data.Aeson-import GHC.Generics+import Data.Data+import Data.Hashable+import GHC.Generics (Generic)+import Safe.Plus+import Test.QuickCheck+import qualified Control.Monad.Fail as Fail  data Option a    = None    | Some !a-   deriving (Show, Eq, Ord, Generic)--instance NFData a => NFData (Option a)--instance Functor Option where-    fmap f x =-        case x of-          None -> None-          Some v -> Some (f v)-    {-# INLINE fmap #-}+   deriving (Show, Read, Eq, Generic, Typeable, Data, Functor, Foldable, Traversable)  instance Applicative Option where     pure = Some@@ -58,16 +62,151 @@     parseJSON x = maybeToOption <$> parseJSON x     {-# INLINE parseJSON #-} +newtype OptionT m a+    = OptionT+    { runOptionT :: m (Option a)+    }++runOptionTDef :: Functor m => a -> OptionT m a -> m a+runOptionTDef x = fmap (fromOption x) . runOptionT++class ToOptionT t where+    optionT :: Monad m => m (t a) -> OptionT m a++instance ToOptionT Maybe where+    optionT = OptionT . fmap maybeToOption++instance ToOptionT Option where+    optionT = OptionT++instance Functor m => Functor (OptionT m) where+  fmap f = OptionT . fmap (fmap f) . runOptionT++instance (Functor m, Monad m) => Applicative (OptionT m) where+    pure = return+    (<*>) = ap++instance Monad m => Fail.MonadFail (OptionT m) where+    fail _ = OptionT (return None)++instance Monad m => Monad (OptionT m) where+    fail = safeFail+    return = lift . return+    x >>= f = OptionT (runOptionT x >>= option (return None) (runOptionT . f))++instance Ord a => Ord (Option a) where+    compare x y =+        case x of+          Some a ->+              case y of+                Some b -> compare a b+                None -> GT+          None ->+              case y of+                None -> EQ+                Some _ -> LT++instance NFData a => NFData (Option a) where+    rnf None = ()+    rnf (Some b) = rnf b++instance MonadTrans OptionT where+    lift x = OptionT (Some <$> x)++instance (MonadIO m) => MonadIO (OptionT m) where+    liftIO = lift . liftIO++instance Fail.MonadFail Option where+    fail _ = None++instance Arbitrary a => Arbitrary (Option a) where+    arbitrary = frequency [(1, return None), (3, Some <$> arbitrary)]++    shrink (Some x) = None : [ Some x' | x' <- shrink x ]+    shrink _        = []++noneIf :: (a -> Bool) -> a -> Option a+noneIf p x+    | p x = None+    | otherwise = Some x++fromOption :: a -> Option a -> a+fromOption def opt =+    case opt of+      Some x -> x+      None -> def++isSome :: Option a -> Bool+isSome (Some _) = True+isSome _ = False++isNone :: Option a -> Bool+isNone None = True+isNone _ = False+ optionToMaybe :: Option a -> Maybe a-optionToMaybe x =-    case x of-      Some v -> Just v-      None -> Nothing+optionToMaybe (Some a) = Just a+optionToMaybe None = Nothing {-# INLINE optionToMaybe #-} +-- |+-- prop> maybeToOption (optionToMaybe x) == x maybeToOption :: Maybe a -> Option a-maybeToOption x =-    case x of-      Just v -> Some v-      Nothing -> None+maybeToOption (Just a) = Some a+maybeToOption Nothing = None {-# INLINE maybeToOption #-}++optionToList :: Option a -> [a]+optionToList (Some a) = [a]+optionToList None = []++optionToSL :: Option a -> StrictList a+optionToSL (Some a) = a :! Nil+optionToSL None = Nil++listToOption :: [a] -> Option a+listToOption [] = None+listToOption (x:_) = Some x++getSomeNote :: Monad m => String -> Option a -> m a+getSomeNote str = option (safeFail str) return++option :: b -> (a -> b) -> Option a -> b+option def f opt =+    case opt of+      Some a -> f $! a+      None -> def++catOptions :: [Option a] -> [a]+catOptions ls = [x | Some x <- ls]++mapOption :: (a -> Option b) -> [a] -> [b]+mapOption _ [] = []+mapOption f (x:xs) =+    let rs = mapOption f xs in+    case f x of+      None -> rs+      Some r  -> r : rs++instance Hashable a => Hashable (Option a)++forOptionM :: Monad m => [a] -> (a -> OptionT m b) -> m [b]+forOptionM xs f = catOptions <$> forM xs (runOptionT . f)++mapOptionM :: Monad m => (a -> OptionT m b) -> [a] -> m [b]+mapOptionM = flip forOptionM++safeFromSome :: Option a -> a+safeFromSome = fromOption (safeError "fromSome is None!")++failToOption :: Fail a -> Option a+failToOption (Ok x) = Some x+failToOption _ = None++optionToFail :: String -> Option a -> Fail a+optionToFail _ (Some x) = Ok x+optionToFail err None = Fail err++optionToFailT :: Monad m => String -> Option a -> FailT m a+optionToFailT _ (Some x) = return x+optionToFailT err None = safeFail err
+ src/Data/StrictList.hs view
@@ -0,0 +1,622 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+module Data.StrictList+    ( StrictList(..)+    , SL+    , (+!+)+    , (\!\)+    , all+    , any+    , atIdx+    , break+    , catMaybes+    , catOptions+    , catOptionsL+    , concat+    , concatSL+    , concatMap+    , concatMapSL+    , concatMapM+    , concatText+    , delete+    , deleteBy+    , deleteIdx+    , drop+    , dropWhile+    , dropWhileEnd+    , elem+    , filter+    , find+    , findIndex+    , fromLazyList, toLazyList+    , groupBy+    , headM+    , headOpt+    , insert+    , insertBy+    , intercalateString+    , intercalateText+    , intersperse+    , lastM+    , lastOpt+    , length+    , ll+    , lookup+    , lookupM+    , lookupM'+    , lookupM''+    , map+    , mapM+    , mapM_+    , mapMaybe+    , mapOption+    , maximumM+    , maybeToStrictList+    , mconcatSL+    , notElem+    , nub+    , null+    , optionToStrictList+    , partition+    , replicate+    , reverse+    , singleton+    , sl+    , snoc+    , merge+    , mergeBy+    , sort+    , sortBy+    , sortOn+    , span+    , stripPrefix+    , stripSuffix+    , tailOpt+    , take+    , takeWhile+    , transpose+    , unzip+    , unzipL+    , unzipLL+    , zip+    , zipLL+    , zipLS+    , zipSL+    , zipWith+    , zipWithLS+    , zipWithSL+    )+where++import Data.Option hiding (catOptions, mapOption)+import Data.StrictList.Types+import Data.StrictTuple++import Data.Hashable+import Data.Ord (comparing)+import Prelude hiding+    ( (!!)+    , all+    , any+    , break+    , concat+    , concatMap+    , drop+    , dropWhile+    , elem+    , filter+    , length+    , lookup+    , map+    , mapM+    , mapM_+    , notElem+    , null+    , replicate+    , reverse+    , span+    , take+    , takeWhile+    , unzip+    , zip+    , zipWith+    )+import Safe.Plus+import qualified Data.Foldable as F+import qualified Data.HashSet as HashSet+import qualified Data.List as L+import qualified Data.Text as T+import qualified Data.Traversable as Tr+import qualified Prelude as P++sl :: [a] -> SL a+sl = fromLazyList++ll :: SL a -> [a]+ll = toLazyList++-- |+-- >>> null (sl [])+-- True+--+-- >>> null (sl ["foo"])+-- False+null :: StrictList a -> Bool+null Nil = True+null _ = False++-- |+-- prop> not (null xs) ==> isSome (headOpt xs)+headOpt :: StrictList a -> Option a+headOpt Nil = None+headOpt (x :! _) = Some x++headM :: Monad m => StrictList a -> m a+headM xxs =+    case xxs of+      Nil -> safeFail "headM of empty strict list."+      (x :! _) -> return x++-- | Safe 'Prelude.tail' function: Returns 'None' for an empty list,+-- 'Some' @x@ for a non-empty list starting with @x@.+tailOpt :: StrictList a -> Option (StrictList a)+tailOpt Nil = None+tailOpt (_ :! xs) = Some xs++lastOpt :: StrictList a -> Option a+lastOpt = lastM++lastM :: Monad m => StrictList a -> m a+lastM xxs =+    case xxs of+      Nil -> safeFail "No last element in strict list."+      (x :! Nil) -> return x+      (_ :! xs) -> lastM xs++-- |+-- >>> optionToStrictList (Some "foo")+-- ["foo"]+--+-- >>> optionToStrictList None+-- []+optionToStrictList :: Option a -> StrictList a+optionToStrictList None = Nil+optionToStrictList (Some x) = x :! Nil++-- |+-- >>> maybeToStrictList (Just "bar")+-- ["bar"]+--+-- >>> maybeToStrictList Nothing+-- []+maybeToStrictList :: Maybe a -> StrictList a+maybeToStrictList Nothing = Nil+maybeToStrictList (Just x) = x :! Nil++takeWhile :: (a -> Bool) -> StrictList a -> StrictList a+takeWhile _ Nil = Nil+takeWhile p (x :! xs)+    | p x = x :! takeWhile p xs+    | otherwise = Nil++-- |+-- >>> drop 3 (sl [1, 2, 3, 4, 5])+-- [4,5]+drop :: Int -> StrictList a -> StrictList a+drop _ Nil = Nil+drop n xss@(_ :! xs)+    | n <= 0 = xss+    | otherwise = drop (n - 1) xs++-- |+-- 'deleteIdx' @idx@ removes the element at index @idx@.+--+-- prop> not (null xs) ==> Some (deleteIdx 0 xs) == tailOpt xs+deleteIdx :: Int -> StrictList a -> StrictList a+deleteIdx _ Nil = Nil+deleteIdx idx lst@(x :! xs) =+    case idx of+      0 ->+          case xs of+            Nil -> Nil+            l -> l+      i ->+          if i < 0+          then lst+          else x :! deleteIdx (i-1) xs++-- | 'delete' @x@ removes the first occurrence of @x@ from its list argument.+-- NOTE: Implementation copied from Data.List.+delete :: (Eq a) => a -> SL a -> SL a+delete = deleteBy (==)++-- | The 'deleteBy' function behaves like 'delete', but takes a+-- user-supplied equality predicate.+-- NOTE: Implementation copied from Data.List.+deleteBy :: (a -> a -> Bool) -> a -> SL a -> SL a+deleteBy eq x yys =+    case yys of+      Nil -> Nil+      (y:!ys) -> if x `eq` y then ys else y :! deleteBy eq x ys++atIdx :: Int -> StrictList a -> Option a+atIdx _ Nil = None+atIdx idx (p :! ps) =+    case idx of+      0 -> Some p+      i ->+          if i < 0+          then None+          else atIdx (i-1) ps++dropWhile :: (a -> Bool) -> StrictList a -> StrictList a+dropWhile _ Nil = Nil+dropWhile p (x :! xs)+    | p x = dropWhile p xs+    | otherwise = x :! xs++findIndex :: (a -> Bool) -> StrictList a -> Option Int+findIndex _ Nil = None+findIndex p (x :! xs)+    | p x = Some 0+    | otherwise = (+1) <$> findIndex p xs++map :: (a -> b) -> StrictList a -> StrictList b+map = fmap++mapM :: Monad m => (a -> m b) -> StrictList a -> m (StrictList b)+mapM = Tr.mapM++mapM_ :: Monad m => (a -> m b) -> StrictList a -> m ()+mapM_ = F.mapM_++-- | Equivalent of 'Prelude.filter' with 'StrictList'.+filter :: (a -> Bool) -> StrictList a -> StrictList a+filter _ Nil = Nil+filter pred (x :! xs)+    | pred x = x :! filter pred xs+    | otherwise = filter pred xs++-- | Equivalent of 'Data.Maybe.catMaybes' with 'StrictList'.+catMaybes :: StrictList (Maybe a) -> StrictList a+catMaybes xs =+    case xs of+      Nil -> Nil+      (Nothing :! xs) -> catMaybes xs+      (Just x :! xs ) -> x :! catMaybes xs++-- | Equivalent of 'Data.Maybe.mapMaybe' with 'StrictList'.+mapMaybe :: (a -> Maybe b) -> StrictList a -> StrictList b+mapMaybe f = catMaybes . map f++-- | Equivalent of 'Data.Maybe.mapMaybe' with 'Option' and 'StrictList'.+--+-- >>> mapOption (\x -> if even x then Some (x * 2) else None) (sl [1, 2, 3, 4, 5])+-- [4,8]+mapOption :: (a -> Option b) -> StrictList a -> StrictList b+mapOption f = catOptions . map f++-- | Equivalent to 'Data.Maybe.catMaybes' with 'Option' and 'StrictList'.+--+-- >>> catOptions (sl [Some 1, None, Some 2, None, None, Some 3, Some 4])+-- [1,2,3,4]+catOptions :: StrictList (Option a) -> StrictList a+catOptions xs =+    case xs of+      Nil -> Nil+      (None :! xs) -> catOptions xs+      (Some x :! xs) -> x :! catOptions xs++-- |+-- >>> catOptionsL [Some 1, None, Some 2, None, None, Some 3, Some 4]+-- [1,2,3,4]+catOptionsL :: [Option a] -> StrictList a+catOptionsL xs =+    case xs of+      [] -> Nil+      (None : xs) -> catOptionsL xs+      (Some x : xs) -> x :! catOptionsL xs++-- |+-- >>> take 3 (sl [1, 2, 3, 4, 5, 6, 7])+-- [1,2,3]+take :: Int -> StrictList a -> StrictList a+take _ Nil = Nil+take n _ | n <= 0 = Nil+take n (x :! xs) = x :! take (n-1) xs++sort :: (Ord a) => StrictList a -> StrictList a+sort = sortBy compare++-- |+-- >>> sortOn snd (sl [("foo", 10), ("bar", 1), ("baz", 100)])+-- [("bar",1),("foo",10),("baz",100)]+sortOn :: (Ord b) => (a -> b) -> StrictList a -> StrictList a+sortOn f =+    map snd+    . sortBy (comparing fst)+    . map (\x -> let y = f x+                 in y `seq` (y,x))++replicate :: Integral i => i -> a -> StrictList a+replicate i a =+    case i of+      0 -> Nil+      n -> a :! replicate (n-1) a++-- |+-- prop> reverse (reverse xs) == xs+reverse :: StrictList a -> StrictList a+reverse l =  rev l Nil+  where+    rev xxs !a =+        case xxs of+          Nil -> a+          (x :! xs) -> rev xs (x :! a)++merge :: Ord a => StrictList a -> StrictList a -> StrictList a+merge = mergeBy compare++mergeBy :: (a -> a -> Ordering) -> StrictList a -> StrictList a -> StrictList a+mergeBy cmp = go+    where+      go as@(a :! as') bs@(b :! bs') =+          case cmp a b of+            LT -> a :! go as' bs+            GT -> b :! go as bs'+            EQ -> a :! go as' bs'+      go Nil bs = bs+      go as Nil = as++sortBy :: (a -> a -> Ordering) -> StrictList a -> StrictList a+sortBy cmp = mergeAll . sequences+  where+    sequences (a :! (b :! xs))+      | a `cmp` b == GT = descending b (a :! Nil) xs+      | otherwise       = ascending  b (a :!) xs+    sequences xs = xs :! Nil+    descending a as (b :! bs)+      | a `cmp` b == GT = descending b (a :! as) bs+    descending a as bs  = (a :! as) :! sequences bs+    ascending a as (b:!bs)+      | a `cmp` b /= GT = ascending b (\ys -> as (a :! ys)) bs+    ascending a as bs   = as (a :! Nil) :! sequences bs+    mergeAll (x :! Nil) = x+    mergeAll xs  = mergeAll (mergePairs xs)+    mergePairs (a :! (b :! xs)) = (merge a b) :! mergePairs xs+    mergePairs xs       = xs+    merge as@(a :! as') bs@(b :! bs')+      | a `cmp` b == GT = b :! merge as  bs'+      | otherwise       = a :! merge as' bs+    merge Nil bs         = bs+    merge as Nil         = as++span :: (a -> Bool) -> StrictList a -> (StrictList a, StrictList a)+span _ Nil =  (Nil, Nil)+span p xs@(x :! xs')+    | p x = let (ys, zs) = span p xs' in (x :! ys, zs)+    | otherwise = (Nil, xs)++break :: (a -> Bool) -> StrictList a -> (StrictList a, StrictList a)+break p =  span (not . p)++concat :: F.Foldable t => t (StrictList a) -> StrictList a+concat = F.fold++concatSL :: SL (SL a) -> SL a+concatSL = concat++concatMap :: F.Foldable t => (a -> StrictList b) -> t a -> StrictList b+concatMap = F.foldMap++concatMapSL :: (a -> StrictList b) -> SL a -> StrictList b+concatMapSL = concatMap++concatMapM  :: (Monad m) => (a -> m (SL b)) -> SL a -> m (SL b)+concatMapM f xs = concat <$> mapM f xs++any :: (a -> Bool) -> StrictList a -> Bool+any = F.any++all :: (a -> Bool) -> StrictList a -> Bool+all = F.all++elem :: Eq a => a -> StrictList a -> Bool+elem = F.elem++notElem :: Eq a => a -> StrictList a -> Bool+notElem = F.notElem++find :: (a -> Bool) -> StrictList a -> Maybe a+find = F.find++zip :: StrictList a -> StrictList b -> StrictList (a :!: b)+zip Nil _ = Nil+zip _ Nil = Nil+zip (x :! xs) (y :! ys) = (x :!: y) :! (zip xs ys)++zipSL :: StrictList a -> [b] -> StrictList (a :!: b)+zipSL Nil _ = Nil+zipSL _ [] = Nil+zipSL (x :! xs) (y : ys) = (x :!: y) :! (zipSL xs ys)++zipLS :: [a] -> StrictList b -> StrictList (a :!: b)+zipLS [] _ = Nil+zipLS _ Nil = Nil+zipLS (x : xs) (y :! ys) = (x :!: y) :! (zipLS xs ys)++zipLL :: [a] -> [b] -> StrictList (a :!: b)+zipLL [] _ = Nil+zipLL _ [] = Nil+zipLL (x : xs) (y : ys) = (x :!: y) :! (zipLL xs ys)++zipWith :: (a->b->c) -> SL a-> SL b -> SL c+zipWith f (a:!as) (b:!bs) = f a b :! zipWith f as bs+zipWith _ _ _ = Nil++-- zipWith - left list is lazy, right list is strict+zipWithLS :: (a->b->c) -> [a]-> SL b -> SL c+zipWithLS f (a:as) (b:!bs) = f a b :! zipWithLS f as bs+zipWithLS _ _ _ = Nil++-- zipWith - left list is strict, right list is lazy+zipWithSL :: (a->b->c) -> SL a-> [b] -> SL c+zipWithSL f (a:!as) (b:bs) = f a b :! zipWithSL f as bs+zipWithSL _ _ _ = Nil++concatText :: StrictList T.Text -> T.Text+concatText = T.concat . toLazyList++concatString :: StrictList String -> String+concatString = P.concat . toLazyList++groupBy :: (a -> a -> Bool) -> StrictList a -> StrictList (StrictList a)+groupBy _ Nil =  Nil+groupBy eq (x:!xs) =  (x:!ys) :! groupBy eq zs+    where (ys,zs) = span (eq x) xs++intersperse :: a -> StrictList a -> StrictList a+intersperse y =+    F.foldr' prepend Nil+    where+      prepend x xs =+          case xs of+            Nil -> x :! Nil+            _ -> x :! y :! xs++intercalateText :: T.Text -> StrictList T.Text -> T.Text+intercalateText t =+    concatText . intersperse t++intercalateString :: String -> SL String -> String+intercalateString s =+    concatString . intersperse s++singleton :: a -> StrictList a+singleton x =+    x :! Nil++lookupM' :: (Monad m, Eq a) => (a -> String) -> a -> StrictList (a :!: b) -> m b+lookupM' showA x = fmap snd' . lookupM'' showA (Just . fst') x++-- | @lookupM'' showKey getKey getValue key list@ searches for @key@ in+-- @list@ using @getKey@ as the key extraction function and @showKey@ to print+-- all available keys when no match is found.+lookupM'' :: (Monad m, Eq k) => (k -> String) -> (a -> Maybe k) -> k -> StrictList a -> m a+lookupM'' showKey getKey wantedK list = loop list+    where+      loop xxs =+          case xxs of+            Nil ->+                let keys = ll $ mapMaybe getKey list+                    keyCount = P.length keys+                    count = P.length list+                in safeFail $+                   "Didn't find " ++ showKey wantedK ++ " in the list with these keys ["+                   ++ L.intercalate ", " (fmap showKey keys) ++ "]. " +++                   if keyCount == count+                      then ""+                      else ("Only " ++ show keyCount ++ "/" ++ show count ++ " entries had a key.")+            (x@(getKey -> Just curK) :! xs)+                | wantedK == curK -> return x+                | otherwise -> loop xs+            _ :! xs -> loop xs++lookupM :: (Monad m, Show a, Eq a) => a -> StrictList (a :!: b) -> m b+lookupM = lookupM' show++lookup :: Eq a => a -> StrictList (a :!: b) -> Option b+lookup = lookupM' (const "fail in Option is None")++insert :: Ord a => a -> SL a -> SL a+insert = insertBy compare++insertBy :: (a -> a -> Ordering) -> a -> SL a -> SL a+insertBy cmp x yss =+    case yss of+      Nil -> x :! Nil+      y:!ys ->+          case cmp x y of+            GT -> y :! insertBy cmp x ys+            _ -> x :! yss++partition :: (a -> Bool) -> SL a -> (SL a, SL a)+partition p =+    F.foldr (select p) (Nil, Nil)+    where+        select :: (a -> Bool) -> a -> (SL a, SL a) -> (SL a, SL a)+        select p x (ts, fs)+            | p x       = (x :! ts, fs)+            | otherwise = (ts, x :! fs)++dropWhileEnd :: (a -> Bool) -> SL a -> SL a+dropWhileEnd p =+    F.foldr (\x xs -> if p x && null xs then Nil else x :! xs) Nil++maximumM :: (Ord a, Monad m) => SL a -> m a+maximumM xxs =+    case xxs of+      Nil -> safeFail "Empty list doesn't have a maximum."+      (x :! xs) -> return $! loop x xs+    where+      loop x yys =+          case yys of+            Nil -> x+            (y :! ys) -> loop (max x y) ys++mconcatSL :: Monoid a => SL a -> a+mconcatSL = F.foldr mappend mempty++stripPrefix :: Eq a => SL a -> SL a -> Maybe (SL a)+stripPrefix Nil ys = Just ys+stripPrefix (x :! xs) (y :! ys) | x == y = stripPrefix xs ys+stripPrefix _ _ = Nothing++stripSuffix :: Eq a => SL a -> SL a -> Maybe (SL a)+stripSuffix suffix xs = fmap reverse (stripPrefix (reverse suffix) (reverse xs))++-- unzip strict list of strict tuples to strict lists of strict tuples+unzip :: SL (a :!: b) -> (SL a :!: SL b)+unzip =  F.foldr (\(a :!: b) (as :!: bs) -> (a:!as :!: b:!bs)) (Nil :!: Nil)++-- unzip lazy list of lazy tuples to strict lists of strict tuples+unzipLL :: [(a,b)] -> (SL a :!: SL b)+unzipLL =  F.foldr (\(a,b) (as :!: bs) -> (a:!as :!: b:!bs)) (Nil :!: Nil)++-- unzip lazy list of strict tuples to strict lists of strict tuples+unzipL :: [(a:!:b)] -> (SL a :!: SL b)+unzipL =  F.foldr (\(a:!:b) (as :!: bs) -> (a:!as :!: b:!bs)) (Nil :!: Nil)++-- | Appends an element to the end of this list.  This is really inefficient because the+-- whole list needs to be copied.  Use at your own risk.+snoc :: SL a -> a -> SL a+snoc xxs y =+    case xxs of+      Nil -> y :! Nil+      x :! xs -> x :! snoc xs y++-- NOTE: copied from Data.List+transpose :: SL (SL a) -> SL (SL a)+transpose xxs =+    case xxs of+      Nil -> Nil+      (Nil :! ys) -> transpose ys+      ((x:!xs) :! xss) -> (x :! [h | (h:!_) <- xss]) :! transpose (xs :! [ t | (_:!t) <- xss])++(\!\) :: (Eq a) => SL a -> SL a -> SL a+(\!\) = F.foldl (flip delete)++nub :: (Eq a, Hashable a) => SL a -> SL a+nub = nub' HashSet.empty+    where+      nub' acc xxs =+          case xxs of+            Nil -> Nil+            x :! xs+                | x `HashSet.member` acc -> nub' acc xs+                | otherwise -> x :! nub' (HashSet.insert x acc) xs
+ src/Data/StrictList/Types.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Data.StrictList.Types where++import Control.Applicative+import Control.DeepSeq+import Control.Monad hiding (forM_, mapM, mapM_)+import Data.Aeson+import Data.Data+import Data.Hashable (Hashable)+import Data.Monoid+import Data.Traversable hiding (mapM)+import GHC.Exts+import GHC.Generics (Generic)+import Prelude (Eq(..), Ord(..), Show(..), (.), (+), Bool)+import Test.QuickCheck+import Text.Read+import qualified Control.Monad.Fail+import qualified Data.Foldable as F++type SL = StrictList++data StrictList a+    = Nil+    | !a :! !(StrictList a)+    deriving (Eq,Ord,Functor,F.Foldable,Traversable,Typeable,Generic,Data)++instance Read a => Read (StrictList a) where+    readPrec = fromLazyList <$> readPrec++instance Show a => Show (StrictList a) where+    showsPrec n xs = showsPrec n (toLazyList xs)++infixr 5  +!++infixr 5  :!++(+!+) :: StrictList a -> StrictList a -> StrictList a+(+!+) Nil ys = ys+(+!+) (x :! xs) ys = x :! (xs +!+ ys)++instance Applicative StrictList where+    pure = return+    (<*>) = ap++instance Alternative StrictList where+    empty = Nil+    (<|>) = (+!+)++instance Control.Monad.Fail.MonadFail StrictList where+    fail _ = Nil++instance Monad StrictList where+    return = (:! Nil)+    (>>=) xs f = F.asum (fmap f xs)+    fail = Control.Monad.Fail.fail++instance Arbitrary a => Arbitrary (StrictList a) where+    arbitrary =+        do v <- arbitrary+           return (fromLazyList v)++instance Monoid (StrictList a) where+    mempty = Nil+    mappend = (+!+)++instance Hashable a => Hashable (StrictList a)++instance ToJSON a => ToJSON (StrictList a) where+    toJSON = toJSON . toLazyList++instance FromJSON a => FromJSON (StrictList a) where+    parseJSON = fmap fromLazyList . parseJSON++instance NFData a => NFData (StrictList a)++instance IsList (StrictList a) where+    type Item (StrictList a) = a+    fromList = fromLazyList+    toList = toLazyList++length :: StrictList a -> Int+length xxs =+    case xxs of+      _ :! xs -> 1 + length xs+      Nil -> 0++fromLazyList :: [a] -> StrictList a+fromLazyList [] = Nil+fromLazyList (x : xs) = x :! fromLazyList xs++toLazyList :: StrictList a -> [a]+toLazyList Nil = []+toLazyList (x :! xs) = x : toLazyList xs++prop_StrictListOrd :: [Int] -> [Int] -> Bool+prop_StrictListOrd l1 l2 =+    let l1' = fromLazyList l1+        l2' = fromLazyList l2+    in compare l1 l2 == compare l1' l2'
+ src/Data/StrictTuple.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+module Data.StrictTuple+    ( module Data.Strict.Tuple+    , toLazyTuple+    , fromLazyTuple+    , fst', snd'+    , uncurry'+    , first, second+    , swap, swap'+    , fst3, snd3, thr3+    , fst3', snd3', thr3'+    )+where++import Control.DeepSeq (NFData(..))+import Data.Aeson+import Data.Data+import Data.Hashable+import Data.Strict.Tuple hiding (fst, snd)+import Data.Tuple+import Test.QuickCheck+import qualified Data.Strict.Tuple++deriving instance Typeable Pair+deriving instance (Data a, Data b) => Data (Pair a b)++instance (Hashable a, Hashable b) => Hashable (Pair a b) where+    hashWithSalt s (a :!: b) = hashWithSalt s a `hashWithSalt` b++instance (NFData a, NFData b) => NFData (Pair a b) where+    rnf (a :!: b) = rnf a `seq` rnf b++instance (Monoid a, Monoid b) => Monoid (Pair a b) where+    mempty = mempty :!: mempty+    (a1 :!: b1) `mappend` (a2 :!: b2) = a1 `mappend` a2 :!: b1 `mappend` b2++instance (Arbitrary a, Arbitrary b) => Arbitrary (Pair a b) where+    arbitrary = (:!:) <$> arbitrary <*> arbitrary++instance (ToJSON a, ToJSON b) => ToJSON (Pair a b) where+    toJSON = toJSON . toLazyTuple++instance (FromJSON a, FromJSON b) => FromJSON (Pair a b) where+    parseJSON = fmap fromLazyTuple . parseJSON++toLazyTuple :: a :!: b -> (a, b)+toLazyTuple (x :!: y) = (x, y)++fromLazyTuple :: (a, b) -> a :!: b+fromLazyTuple (x, y) = x :!: y++fst' :: Pair a b -> a+fst' = Data.Strict.Tuple.fst++snd' :: Pair a b -> b+snd' = Data.Strict.Tuple.snd++uncurry' :: (a -> b -> c) -> Pair a b -> c+uncurry' = Data.Strict.Tuple.uncurry++first :: (a -> b) -> (a :!: c) -> (b :!: c)+first f (a :!: c) = f a :!: c++second :: (b -> c) -> (a :!: b) -> (a :!: c)+second f (a :!: b) = a :!: f b++swap' :: (a :!: b) -> (b :!: a)+swap' (x :!: y) = y :!: x++fst3 :: (a, b, c) -> a+fst3 (x, _, _) = x++snd3 :: (a, b, c) -> b+snd3 (_, x, _) = x++thr3 :: (a, b, c) -> c+thr3 (_, _, x) = x++fst3' :: (a :!: b :!: c) -> a+fst3' (x :!: _ :!: _) = x++snd3' :: (a :!: b :!: c) -> b+snd3' (_ :!: x :!: _) = x++thr3' :: (a :!: b :!: c) -> c+thr3' (_ :!: _ :!: x) = x
+ src/Data/StrictVector.hs view
@@ -0,0 +1,347 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Data.StrictVector+    ( module Data.Vector.Generic+    , Vector+    , null, length, (!), (!?), head, last+    , fromList, fromListN, toList, empty, singleton+    , generate, generateM+    , catMaybes, mapMaybe, lastMay, toHashSet+    , lookAround+    , dropWhileEnd+    , dropWhileLookingAround+    , fromSL+    , imapM, binarySearchL, binarySearchR+    , sort+    , sortBy+    , sortOn+    , groupBy+    , groupOn+    , toSL+    , uncons+    , updateVector, updateVectorWith+    , unfoldrM, unfoldrNM+    , theOnlyOne+    ) where++import Data.Option+import Data.StrictList (SL, toLazyList, fromLazyList)+-- import qualified Cpm.Util.List as L+import qualified Data.StrictVector.Mutable as VM++import Control.DeepSeq (NFData)+import Control.Monad+import Data.Aeson (ToJSON, FromJSON(..))+import Data.Bits (shiftR)+import Data.Data+import Data.HashSet (HashSet)+import Data.Hashable (Hashable(..))+import Data.Vector.Generic hiding+    ( Vector, fromList, fromListN, toList, empty, singleton, null, length ,(!), (!?), head, last+    , imapM, generate, generateM, unfoldrNM, unfoldrM, mapMaybe)+import Prelude hiding+    ( map, drop, dropWhile, concatMap, length, zip3, mapM, null, (++), replicate, head, last)+import Safe.Plus+import Test.QuickCheck (Arbitrary(..))+import Text.Read+import qualified Control.Applicative as A+import qualified Control.Monad.Fail+import qualified Data.HashSet as HashSet+import qualified Data.Vector as V+import qualified Data.Vector.Algorithms.Intro as VA (sortBy, sort)+import qualified Data.Vector.Fusion.Bundle.Monadic as VFM+import qualified Data.Vector.Generic as VG+import qualified GHC.Exts as Exts++newtype Vector a = Vector (V.Vector a)+    deriving (Eq, Ord, NFData, ToJSON, Monoid, Foldable, Data, Typeable)++type instance VG.Mutable Vector = VM.MVector++instance VG.Vector Vector a where+    basicUnsafeFreeze (VM.MVector v) = fmap Vector (basicUnsafeFreeze v)+    basicUnsafeThaw (Vector v) = fmap VM.MVector (basicUnsafeThaw v)+    basicLength (Vector v) = basicLength v+    basicUnsafeSlice n m (Vector v) = Vector (basicUnsafeSlice n m v)+    basicUnsafeIndexM (Vector v) = basicUnsafeIndexM v+    basicUnsafeCopy (VM.MVector v1) (Vector v2) = basicUnsafeCopy v1 v2+    elemseq _ = seq++instance Show a => Show (Vector a) where+    showsPrec = VG.showsPrec++instance Read a => Read (Vector a) where+    readPrec = VG.readPrec+    readListPrec = readListPrecDefault++instance (Hashable a) => Hashable (Vector a) where+    hashWithSalt = hashVectorWithSalt++instance Arbitrary a => Arbitrary (Vector a) where+    arbitrary = VG.fromList <$> arbitrary++instance Functor Vector where+    {-# INLINE fmap #-}+    fmap = VG.map++instance Control.Monad.Fail.MonadFail Vector where+    {-# INLINE fail #-}+    fail _ = VG.empty++instance Monad Vector where+    {-# INLINE return #-}+    return = VG.singleton+    {-# INLINE (>>=) #-}+    (>>=) = flip VG.concatMap+    {-# INLINE fail #-}+    fail = safeFail++instance MonadPlus Vector where+    {-# INLINE mzero #-}+    mzero = VG.empty+    {-# INLINE mplus #-}+    mplus = (VG.++)++instance Applicative Vector where+    {-# INLINE pure #-}+    pure = VG.singleton+    {-# INLINE (<*>) #-}+    (<*>) = ap++instance A.Alternative Vector where+    {-# INLINE empty #-}+    empty = VG.empty+    {-# INLINE (<|>) #-}+    (<|>) = (VG.++)++instance Traversable Vector where+    {-# INLINE traverse #-}+    traverse f xs = fromList <$> traverse f (toList xs)+    {-# INLINE mapM #-}+    mapM = VG.mapM+    {-# INLINE sequence #-}+    sequence = VG.sequence++instance Exts.IsList (Vector a) where+    type Item (Vector a) = a+    fromList = fromList+    fromListN = fromListN+    toList = toList++instance FromJSON a => FromJSON (Vector a) where+    parseJSON x = (convert :: V.Vector a -> Vector a) <$> parseJSON x++-- | /O(1)/ Yield the length of the vector.+length :: Vector a -> Int+{-# INLINE length #-}+length = VG.length++-- | /O(1)/ Test whether a vector if empty+null :: Vector a -> Bool+{-# INLINE null #-}+null = VG.null++-- | O(1) Indexing+(!) :: Vector a -> Int -> a+{-# INLINE (!) #-}+(!) = (VG.!)++-- | O(1) Safe indexing+(!?) :: Vector a -> Int -> Maybe a+{-# INLINE (!?) #-}+(!?) = (VG.!?)++-- | /O(1)/ First element+head :: Vector a -> a+{-# INLINE head #-}+head = VG.head++-- | /O(1)/ Last element+last :: Vector a -> a+{-# INLINE last #-}+last = VG.last++fromList :: [a] -> Vector a+{-# INLINE fromList #-}+fromList = VG.fromList++fromListN :: Int -> [a] -> Vector a+{-# INLINE fromListN #-}+fromListN = VG.fromListN++toList :: Vector a -> [a]+{-# INLINE toList #-}+toList = VG.toList++singleton :: a -> Vector a+{-# INLINE singleton #-}+singleton = VG.singleton++empty :: Vector a+{-# INLINE empty #-}+empty = VG.empty++generate :: Int -> (Int -> a) -> Vector a+{-# INLINE generate #-}+generate = VG.generate++generateM :: Monad m => Int -> (Int -> m a) -> m (Vector a)+{-# INLINE generateM #-}+generateM = VG.generateM++fromSL :: SL a -> Vector a+{-# INLINE fromSL #-}+fromSL = VG.fromList . toLazyList++toSL :: Vector a -> SL a+{-# INLINE toSL #-}+toSL = fromLazyList . toList++{-# INLINABLE hashVectorWithSalt #-}+hashVectorWithSalt :: Hashable a => Int -> Vector a -> Int+hashVectorWithSalt salt v = foldl' hashWithSalt salt v++{-# INLINABLE mapMaybe #-}+mapMaybe :: (a -> Maybe b) -> Vector a -> Vector b+mapMaybe f = catMaybes . map f++{-# INLINABLE catMaybes #-}+catMaybes :: Vector (Maybe a) -> Vector a+catMaybes = concatMap maybeToVector++{-# INLINABLE maybeToVector #-}+maybeToVector :: Maybe a -> Vector a+maybeToVector Nothing = VG.empty+maybeToVector (Just x) = VG.singleton x++{-# INLINABLE lastMay #-}+lastMay :: Vector a -> Maybe a+lastMay vec =+    vec !? ((length vec) - 1)++uncons :: Vector a -> Option (a, Vector a)+uncons v | null v = None+         | otherwise = Some (unsafeHead v, drop 1 v)++-- | Returns `Just` the only element of the vector if there is exactly+-- one element or `Nothing` otherwise.+theOnlyOne :: Vector a -> Maybe a+theOnlyOne xs+    | length xs /= 1 = Nothing+    | otherwise = xs !? 0++{-# INLINABLE lookAround #-}+lookAround :: Vector a -> Vector (Maybe a, a, Maybe a)+lookAround v = zip3 lookBehind v lookAhead+    where+      lookBehind = Nothing `cons` map Just v+      lookAhead = drop 1 (map Just v) `snoc` Nothing++{-# INLINABLE toHashSet #-}+toHashSet :: (Eq a, Hashable a) => Vector a -> HashSet a+toHashSet = foldl' (\set elem -> HashSet.insert elem set) HashSet.empty++dropWhileLookingAround :: (Maybe a -> a -> Maybe a -> Bool) -> Vector a -> Vector a+dropWhileLookingAround f = map (\(_, v, _) -> v) . dropWhile (\(x,y,z) -> f x y z) . lookAround++dropWhileEnd :: (a -> Bool) -> Vector a -> Vector a+dropWhileEnd pred v =+    case pred `fmap` (v !? (length v - 1)) of+      Nothing -> v+      Just False -> v+      Just True ->+          let toDelete count =+                  case pred `fmap` (v !? (length v - count - 1)) of+                    Nothing -> count+                    Just False -> count+                    Just True -> toDelete (count + 1)+          in VG.take (length v - toDelete 1) v++imapM :: Monad m => (Int -> a -> m b) -> Vector a -> m (Vector b)+{-# INLINE imapM #-}+imapM = VG.imapM++binarySearchL :: (e -> Ordering) -> Vector e -> Int+binarySearchL cmp vec = loop 0 (length vec)+ where+   loop !l !u+       | u <= l = l+       | otherwise =+           let k = (u + l) `shiftR` 1+           in case cmp (vec ! k) of+                LT -> loop (k+1) u+                _  -> loop l     k++binarySearchR :: (e -> Ordering) -> Vector e -> Int+binarySearchR cmp vec = loop 0 (length vec)+    where+      loop !l !u+          | u <= l    = l+          | otherwise =+              let k = (u + l) `shiftR` 1+              in case cmp (vec ! k) of+                   GT -> loop l     k+                   _  -> loop (k+1) u++sortOn :: Ord b => (a -> b) -> Vector a -> Vector a+sortOn f = sortBy (\x y -> compare (f x) (f y))++sortBy :: (a -> a -> Ordering) -> Vector a -> Vector a+sortBy comp v =+    modify (VA.sortBy comp) v++sort :: Ord a => Vector a -> Vector a+sort v = modify VA.sort v++groupBy :: (a -> a -> Bool) -> Vector a -> Vector (Vector a)+groupBy eq xs = unfoldrN (VG.length xs) next xs+    where+      next ys+        | VG.null ys = Nothing+        | otherwise =+            let y = VG.unsafeHead ys+                ys' = VG.unsafeTail ys+                (l1,l2) = VG.span (eq y) ys'+            in Just (y `VG.cons` l1, l2)++groupOn :: Eq b => (a -> b) -> Vector a -> Vector (b, (Vector a))+groupOn proj xs = unfoldrN (VG.length xs) next xs+    where+      next ys+        | VG.null ys = Nothing+        | otherwise =+            let y = VG.unsafeHead ys+                z = proj y+                ys' = VG.unsafeTail ys+                (l1,l2) = VG.span (\x -> proj x == z) ys'+            in Just ((z , y `VG.cons` l1), l2)++unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> m (Vector a)+unfoldrM f s = unstreamM (VFM.unfoldrM f s)++unfoldrNM :: Monad m => Int -> (s -> m (Maybe (a, s))) -> s -> m (Vector a)+unfoldrNM n f s = unstreamM (VFM.unfoldrNM n f s)++-- | Copied from Data.Vector.Generic as it isn't exported there+unstreamM :: (Monad m) => VFM.Bundle m u a -> m (Vector a)+{-# INLINE unstreamM #-}+unstreamM s =+    do xs <- VFM.toList s+       return $ unstream $ VFM.unsafeFromList (VFM.size s) xs++updateVector :: Int -> a -> a -> Vector a -> Vector a+updateVector comp def val vect = updateVectorWith comp def (const val) vect++updateVectorWith :: Int -> a -> (a -> a) -> Vector a -> Vector a+updateVectorWith comp def val vect =+    let vect' =+            if comp >= length vect+            then vect ++ replicate (comp - (length vect) + 1) def+            else vect+    in vect' // [(comp, val (vect' ! comp))]
+ src/Data/StrictVector/Mutable.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Data.StrictVector.Mutable+    ( module Data.Vector.Generic.Mutable+    , MVector(..)+    , IOVector, STVector+    )+where++import Control.Monad.ST (RealWorld)+import Data.Vector.Generic.Mutable hiding (MVector)+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector.Mutable as VM++-- | 'MVector' is a strict wrapper around "Data.Vector.Mutable"'s 'Data.Vector.Mutable.MVector'+newtype MVector s a = MVector (VM.MVector s a)++instance VGM.MVector MVector a where+    basicLength (MVector v) = VGM.basicLength v+    basicUnsafeSlice n m (MVector v) = MVector $ VGM.basicUnsafeSlice n m v+    basicOverlaps (MVector v1) (MVector v2) = VGM.basicOverlaps v1 v2+    basicUnsafeNew n = fmap MVector (VGM.basicUnsafeNew n)+    basicInitialize (MVector v) = basicInitialize v+    basicUnsafeReplicate n x = x `seq` fmap MVector (VGM.basicUnsafeReplicate n x)+    basicUnsafeRead (MVector v) n = VGM.basicUnsafeRead v n+    basicUnsafeWrite (MVector v) n x = x `seq` VGM.basicUnsafeWrite v n x+    basicClear (MVector v) = VGM.basicClear v+    basicSet (MVector v) x = x `seq` VGM.basicSet v x+    basicUnsafeCopy (MVector v1) (MVector v2) = VGM.basicUnsafeCopy v1 v2+    basicUnsafeMove (MVector v1) (MVector v2) = VGM.basicUnsafeMove v1 v2+    basicUnsafeGrow (MVector v) n = fmap MVector (VGM.basicUnsafeGrow v n)++type IOVector = MVector RealWorld+type STVector s = MVector s+
strict-data.cabal view
@@ -1,13 +1,15 @@ name:                strict-data-version:             0.1.1.0-synopsis:            Verious useful strict data structures-description:         Please see README.md+version:             0.2.0.2+synopsis:            A collection of commonly used strict data structures+description:         A collection of commonly used strict data structures homepage:            https://github.com/agrafix/strict-data#readme license:             BSD3 license-file:        LICENSE author:              Alexander Thiemann+                   , factis research GmbH maintainer:          mail@athiemann.net copyright:           2016 Alexander Thiemann <mail@athiemann.net>+                   , 2017 factis research GmbH category:            Data build-type:          Simple extra-source-files:@@ -16,10 +18,68 @@  library   hs-source-dirs:      src-  exposed-modules:     Data.Option-  build-depends:       base >= 4.7 && < 5, aeson, deepseq+  exposed-modules:     Data.Choice+                     , Data.Fail+                     , Data.Option+                     , Data.StrictList+                     , Data.StrictTuple+                     , Data.StrictVector+                     , Data.StrictVector.Mutable+                     , Data.Map.Ordered+                     , Data.Map.Unordered+  other-modules:       Data.Fail.Types+                     , Data.StrictList.Types+  build-depends:       base >= 4.7 && < 5+                     , QuickCheck+                     , aeson+                     , deepseq+                     , exceptions+                     , fail+                     , hashable+                     , monad-control+                     , mtl+                     , pretty+                     , resourcet+                     , strict+                     , text+                     , transformers+                     , transformers-base+                     , containers >= 0.5+                     , unordered-containers+                     , util-plus+                     , vector+                     , vector-algorithms   default-language:    Haskell2010+  ghc-options:       -Wall -Wdodgy-imports +test-suite strict-data-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  other-modules:       Fail+                     , Option+                     , StrictList+                     , StrictVector+                     , StrictVector.Mutable+                     , Data.Map.OrderedSpec+  build-depends:       base >= 4.7 && < 5+                     , strict-data+                     , HTF+                     , vector+                     , deepseq+                     , hashable+                     , containers+  ghc-options:       -Wall+  default-language:    Haskell2010++test-suite strict-data-doctest+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Doc.hs+  build-depends:       base >= 4.7 && < 5+                     , doctest+  default-language:    Haskell2010+ source-repository head   type:     git-  location: https://github.com/agrafix/strict-data+  location: https://github.com/factisresearch/opensource-mono
+ test/Data/Map/OrderedSpec.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Data.Map.OrderedSpec+    ( htf_thisModulesTests+    )+where++import Data.Map.Ordered++import Data.Traversable+import Prelude hiding (map, lookup, null, filter)+import System.IO.Unsafe (unsafePerformIO)+import Test.Framework+import qualified Control.Exception as E++newtype OSMapInt = OSMapInt (OSMap Int Int)+    deriving (Eq, Show)++bottom :: a+bottom = undefined++bottomInt :: Int+bottomInt = bottom++-- | A modified variant of 'isBottomTimeOut' that lives in the 'IO' monad.+-- (Taken from ChasingBottoms)+isBottom :: a -> Bool+isBottom f =+    unsafePerformIO $!+    E.evaluate (f `seq` False) `E.catches`+    [ E.Handler (\(_ :: E.ArrayException)   -> return True)+    , E.Handler (\(_ :: E.ErrorCall)        -> return True)+    , E.Handler (\(_ :: E.NoMethodError)    -> return True)+    , E.Handler (\(_ :: E.NonTermination)   -> return True)+    , E.Handler (\(_ :: E.PatternMatchFail) -> return True)+    , E.Handler (\(_ :: E.RecConError)      -> return True)+    , E.Handler (\(_ :: E.RecSelError)      -> return True)+    , E.Handler (\(_ :: E.RecUpdError)      -> return True)+    ]++keyValueByIndex :: Int -> OSMap Int Int -> (Int, Int)+keyValueByIndex i m =+    let n = size m+    in toList m !! (i `mod` n)++valueByIndex :: Int -> OSMap Int Int -> Int+valueByIndex i m = snd (keyValueByIndex i m)++keyByIndex :: Int -> OSMap Int Int -> Int+keyByIndex i m = fst (keyValueByIndex i m)++instance Arbitrary OSMapInt where+    arbitrary =+        do l <- arbitrary+           return $ OSMapInt $ fromList l++prop_insertStrictKey :: OSMapInt -> Int -> Bool+prop_insertStrictKey (OSMapInt m) v =+    isBottom (insert bottom v m)++prop_insertStrictValue :: OSMapInt -> Int -> Bool+prop_insertStrictValue (OSMapInt m) k =+    isBottom (insert k bottom m)++prop_deleteStrict :: OSMapInt -> Bool+prop_deleteStrict (OSMapInt m) = isBottom (delete bottom m)++prop_mapStrict :: OSMapInt -> Int -> Property+prop_mapStrict (OSMapInt m) i =+    not (null m) ==>+    isBottom $ map (\x -> if x == value then bottom else x) m+    where+      value = valueByIndex i m++prop_singletonStrictKey :: Int -> Bool+prop_singletonStrictKey v =+    isBottom $ singleton bottomInt v++prop_singletonStrictValue :: Int -> Bool+prop_singletonStrictValue k =+    isBottom $ singleton k bottom++prop_insertWithStrictKey :: OSMapInt -> Int -> Bool+prop_insertWithStrictKey (OSMapInt m) v =+    isBottom $ insertWith (\_ _ -> 0) bottom v m++prop_insertWithStrictValue1 :: OSMapInt -> Int -> Bool+prop_insertWithStrictValue1 (OSMapInt m) k =+    isBottom $ insertWith (\_ _ -> 0) k bottom m++prop_insertWithStrictValue2 :: OSMapInt -> Int -> Int -> Property+prop_insertWithStrictValue2 (OSMapInt m) v i =+    not (null m) ==>+    isBottom $ insertWith (\_ old -> if old == value then bottom else v) key v m+    where+      (key, value) = keyValueByIndex i m++prop_unionStrictLeft :: OSMapInt -> Bool+prop_unionStrictLeft (OSMapInt m) =+    isBottom $ union bottom m++prop_unionStrictRight :: OSMapInt -> Bool+prop_unionStrictRight (OSMapInt m) =+    isBottom $ union m bottom++prop_differenceStrictLeft :: OSMapInt -> Bool+prop_differenceStrictLeft (OSMapInt m) =+    isBottom $ difference bottom m++prop_differenceStrictRight :: OSMapInt -> Property+prop_differenceStrictRight (OSMapInt m) =+    not (null m) ==>+    isBottom $ difference m bottom++prop_intersectionStrictLeft :: OSMapInt -> Bool+prop_intersectionStrictLeft (OSMapInt m) =+    isBottom $ intersection bottom m++prop_intersectionStrictRight :: OSMapInt -> Property+prop_intersectionStrictRight (OSMapInt m) =+    not (null m) ==>+    isBottom $ intersection m bottom++prop_insertLookupWithKeyStrictKey :: OSMapInt -> Int -> Bool+prop_insertLookupWithKeyStrictKey (OSMapInt m) v =+    isBottom $ snd $ insertLookupWithKey (\_ _ _ -> 0) bottom v m++prop_insertLookupWithKeyStrictValue1 :: OSMapInt -> Int -> Bool+prop_insertLookupWithKeyStrictValue1 (OSMapInt m) k =+    isBottom $ snd $ insertLookupWithKey (\_ _ _ -> 0) k bottom m++prop_insertLookupWithKeyStrictValue2 :: OSMapInt -> Int -> Int -> Property+prop_insertLookupWithKeyStrictValue2 (OSMapInt m) v i =+    not (null m) ==>+    isBottom $ snd $ insertLookupWithKey (\_ _ old -> if old == value then bottom else v) key v m+    where+      (key, value) = keyValueByIndex i m++prop_updateLookupWithKeyStrictKey :: OSMapInt -> Maybe Int -> Bool+prop_updateLookupWithKeyStrictKey (OSMapInt m) v =+    isBottom $ snd $ updateLookupWithKey (\_ _ -> v) bottom m++prop_updateLookupWithKeyStrictValue1 :: OSMapInt -> Maybe Int -> Int -> Property+prop_updateLookupWithKeyStrictValue1 (OSMapInt m) v i =+    not (null m) ==>+    isBottom $ snd $ updateLookupWithKey (\_ old -> if old == value then bottom else v) key m+    where+      (key, value) = keyValueByIndex i m++prop_updateLookupWithKeyStrictValue2 :: OSMapInt -> Maybe Int -> Int -> Property+prop_updateLookupWithKeyStrictValue2 (OSMapInt m) v i =+    not (null m) ==>+    isBottom $ snd $ updateLookupWithKey (\_ old -> if old == value then Just bottom else v) key m+    where+      (key, value) = keyValueByIndex i m++prop_deleteLookupStrict :: OSMapInt -> Property+prop_deleteLookupStrict (OSMapInt m) =+    not (null m) ==>+    isBottom $ snd $ deleteLookup bottom m++prop_alterStrictKey :: OSMapInt -> Bool+prop_alterStrictKey (OSMapInt m) =+    isBottom $ alter id bottom m++prop_alterStrictFun1 :: OSMapInt -> Int -> Property+prop_alterStrictFun1 (OSMapInt m) i =+    not (null m) ==>+    isBottom $ alter (\_ -> Just bottomInt) key m+    where+      key = keyByIndex i m++prop_alterStrictFun2 :: OSMapInt -> Int -> Property+prop_alterStrictFun2 (OSMapInt m) i =+    not (null m) ==>+    isBottom $ alter (\_ -> bottom) key m+    where+      key = keyByIndex i m++prop_differenceWithStrictLeft :: OSMapInt -> Maybe Int -> Bool+prop_differenceWithStrictLeft (OSMapInt m) v =+    isBottom $ differenceWith (\_ _ -> v) bottom m++prop_differenceWithStrictRight :: OSMapInt -> Maybe Int -> Property+prop_differenceWithStrictRight (OSMapInt m) v =+    not (null m) ==>+    isBottom $ differenceWith (\_ _ -> v) m bottom++prop_differenceWithStrictFun1 :: OSMapInt -> Int -> Int -> Property+prop_differenceWithStrictFun1 (OSMapInt m) v i =+    not (null m) ==>+    isBottom $ differenceWith (\_ _ -> Just bottom) m (insert key v m)+    where+      key = keyByIndex i m++prop_differenceWithStrictFun2 :: OSMapInt -> Int -> Int -> Property+prop_differenceWithStrictFun2 (OSMapInt m) v i =+    not (null m) ==>+    isBottom $ differenceWith (\_ _ -> bottom) m (insert key v m)+    where+      key = keyByIndex i m++prop_intersectionWithStrictFun2 :: OSMapInt -> Int -> Int -> Property+prop_intersectionWithStrictFun2 (OSMapInt m) v i =+    not (null m) ==>+    isBottom $ intersectionWith (\_ _ -> bottom) m (insert key v m)+    where+      key = keyByIndex i m++prop_updateWithKeyStrictKey :: OSMapInt -> Maybe Int -> Bool+prop_updateWithKeyStrictKey (OSMapInt m) v =+    isBottom $ updateWithKey (\_ _ -> v) bottom m++prop_updateWithKeyStrictValue1 :: OSMapInt -> Maybe Int -> Int -> Property+prop_updateWithKeyStrictValue1 (OSMapInt m) v i =+    not (null m) ==>+    isBottom $ updateWithKey (\_ old -> if old == value then bottom else v) key m+    where+      (key, value) = keyValueByIndex i m++prop_updateWithKeyStrictValue2 :: OSMapInt -> Maybe Int -> Int -> Property+prop_updateWithKeyStrictValue2 (OSMapInt m) v i =+    not (null m) ==>+    isBottom $ updateWithKey (\_ old -> if old == value then Just bottom else v) key m+    where+      (key, value) = keyValueByIndex i m++prop_insertWithKeyStrictKey :: OSMapInt -> Int -> Bool+prop_insertWithKeyStrictKey (OSMapInt m) v =+    isBottom $ insertWithKey (\_ _ _ -> 0) bottom v m++prop_insertWithKeyStrictValue1 :: OSMapInt -> Int -> Bool+prop_insertWithKeyStrictValue1 (OSMapInt m) k =+    isBottom $ insertWithKey (\_ _ _ -> 0) k bottom m++prop_insertWithKeyStrictValue2 :: OSMapInt -> Int -> Int -> Property+prop_insertWithKeyStrictValue2 (OSMapInt m) v i =+    not (null m) ==>+    isBottom $ insertWithKey (\_ _ old -> if old == value then bottom else v) key v m+    where+      (key, value) = keyValueByIndex i m++prop_mapKeysStrict :: OSMapInt -> Int -> Property+prop_mapKeysStrict (OSMapInt m) i =+    not (null m) ==>+    isBottom $ mapKeys (\k -> if k == key then bottom else k) m+    where+      key = keyByIndex i m++prop_fmapStrict :: OSMapInt -> Int -> Property+prop_fmapStrict (OSMapInt m) i =+    not (null m) ==>+    isBottom $ fmap (\x -> if x == value then bottom else x) m+    where+      value = valueByIndex i m++prop_traverseStrict :: OSMapInt -> Int -> Property+prop_traverseStrict (OSMapInt m) i =+    not (null m) ==>+    isBottom $ fmapDefault (\x -> if x == value then bottom else x) m+    where+      value = valueByIndex i m
+ test/Doc.hs view
@@ -0,0 +1,7 @@+module Main where++import Test.DocTest++main :: IO ()+main = doctest ["src"]+
+ test/Fail.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Fail where++import Data.Fail++import Test.Framework++test_partitionFails :: IO ()+test_partitionFails =+    do assertEqual ([]::[Int], []) (partitionFails [])+       assertEqual ([1::Int], []) (partitionFails [Ok 1])+       assertEqual ([]::[Int], ["bad"]) (partitionFails [Fail "bad"])+       assertEqual ([1,2,3::Int], ["bad1", "bad2"])+           (partitionFails [Ok 1, Fail "bad1", Ok 2, Ok 3, Fail "bad2"])
+ test/Option.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Option where++import Data.Option++import Control.Monad (forM_)+import Data.List+import Test.Framework++test_ord :: IO ()+test_ord =+    let list = [None, None, Some "x", Some "x", Some "y"]+    in forM_ (permutations list) $ \perm ->+           assertEqual list (sort perm)+
+ test/Spec.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++import {-@ HTF_TESTS @-} Data.Map.OrderedSpec+import {-@ HTF_TESTS @-} Fail+import {-@ HTF_TESTS @-} Option+import {-@ HTF_TESTS @-} StrictList+import {-@ HTF_TESTS @-} StrictVector+import {-@ HTF_TESTS @-} StrictVector.Mutable++import Test.Framework++main :: IO ()+main = htfMain htf_importedTests
+ test/StrictList.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -F -pgmF htfpp -fno-warn-type-defaults #-}+module StrictList (htf_thisModulesTests) where++import Data.Option+import Data.StrictList+import Data.StrictTuple++import Prelude hiding+    ( (!!)+    , all+    , any+    , break+    , concat+    , concatMap+    , drop+    , dropWhile+    , elem+    , filter+    , length+    , lookup+    , map+    , mapM+    , mapM_+    , notElem+    , null+    , replicate+    , reverse+    , span+    , take+    , takeWhile+    , unzip+    , zip+    , zipWith+    )+import Test.Framework+import qualified Prelude as P++test_nub :: IO ()+test_nub =+    do assertEqual (sl [1, 5, 2] :: SL Int) $ nub (sl [1, 5, 1, 2, 5, 2])++test_unzip :: IO ()+test_unzip =+    do assertEqual ((1:!2:!Nil) :!: ('a':!'b':!Nil)) (unzip ((1 :!: 'a') :! (2 :!: 'b') :! Nil))+       assertEqual ((1:!2:!Nil) :!: ('a':!'b':!Nil)) (unzipL [(1:!:'a'),(2:!:'b')])+       assertEqual ((1:!2:!Nil) :!: ('a':!'b':!Nil)) (unzipLL [(1,'a'),(2,'b')])++test_dropWhileEnd :: IO ()+test_dropWhileEnd =+    do assertEqual Nil $ dropWhileEnd (<= 1) $ Nil+       assertEqual Nil $ dropWhileEnd (<= 1) $ 1 :! Nil+       assertEqual (1 :! 2 :! Nil) $ dropWhileEnd (<= 1) $ 1 :! 2 :! 1 :! Nil+++prop_partition :: [Int] -> Bool+prop_partition l =+    let me :: ([Int], [Int])+        me = (\(xs, ys) -> (toLazyList xs, toLazyList ys)) $ partition even $ fromLazyList l+    in (P.filter even l, P.filter odd l) == me++test_insert :: IO ()+test_insert =+    do assertEqual (1 :! Nil) (insert 1 Nil)+       assertEqual (1 :! 2 :! Nil) (insert 1 (2 :! Nil))+       assertEqual (1 :! 2 :! Nil) (insert 2 (1 :! Nil))+       assertEqual (1 :! 2 :! 3 :! Nil) (insert 2 (1 :! 3 :! Nil))+       assertEqual (1 :! 2 :! 3 :! Nil) (insert 3 (1 :! 2 :! Nil))+       assertEqual (1 :! 2 :! 2 :! Nil) (insert 2 (1 :! 2 :! Nil))+       assertEqual (2 :! 3 :! 1 :! Nil) (insert 2 (3 :! 1 :! Nil))++test_lookup :: IO ()+test_lookup =+    do assertEqual None (lookup True (mk []))+       assertEqual (Some 'a') (lookup True (mk [(True, 'a')]))+       assertEqual (Some 'a') (lookup True (mk [(False, 'b'),(True, 'a')]))+       assertEqual (Some 'a') (lookup True (mk [(False, 'b'),(True, 'a'),(False, 'c')]))+       assertEqual (Some 'a') (lookup True (mk [(False, 'b'),(False, 'c'),(True, 'a')]))+       assertEqual None (lookup True (mk [(False, 'b')]))+       assertEqual None (lookup True (mk [(False, 'a'), (False, 'b')]))+    where+      mk :: [(Bool,Char)] -> StrictList (Bool :!: Char)+      mk = fromLazyList . fmap fromLazyTuple++prop_take :: Int -> [Int] -> Bool+prop_take l lst =+    let me :: [Int]+        me = toLazyList $ take l (fromLazyList lst)+    in P.take l lst == me++-- test_sort :: IO ()+-- test_sort =+--     do let list = fromLazyList [1..133]+--        list' <- Cpm.Util.Random.shuffle (toLazyList list)+--        assertEqual list (sort (fromLazyList list'))++test_headOpt :: IO ()+test_headOpt =+    do assertEqual (Some "B") $ headOpt $ fromLazyList ["B","C"]+       assertEqual None $ headOpt (Nil :: StrictList ())++test_lastOpt :: IO ()+test_lastOpt =+    do assertEqual (Some 5) $ lastOpt $ fromLazyList [2,4,5]+       assertEqual (Some 5) $ lastOpt $ fromLazyList [5]+       assertEqual None $ lastOpt $ (Nil :: StrictList ())++test_findIndex :: IO ()+test_findIndex =+    do assertEqual None $ findIndex (== "A") $ fromLazyList ["B","C"]+       assertEqual None $ findIndex (== "A") Nil+       assertEqual (Some 1) $ findIndex (== "C") $ fromLazyList ["B","C","D"]+       assertEqual (Some 0) $ findIndex (/= "C") $ fromLazyList ["B","C","D"]++test_reverse :: IO ()+test_reverse =+    do assertEqual (fromLazyList ["D","C","B"]) (reverse $ fromLazyList ["B","C","D"])+       assertEqual (Nil :: StrictList ()) $ reverse Nil++test_replicate :: IO ()+test_replicate =+  do assertEqual (replicate 3 'a') (fromLazyList (P.replicate 3 'a'))+     assertEqual (replicate 3 'b') ('b' :! 'b' :! 'b' :! Nil)+     assertEqual (replicate 0 'c') Nil+     assertEqual (replicate 0 'd') (fromLazyList (P.replicate 0 'e'))++test_dropWhile :: IO ()+test_dropWhile =+    do assertEqual (fromLazyList [5]) $ dropWhile even $ fromLazyList [2,4,5]+       assertEqual (fromLazyList [2,4,5]) $ dropWhile odd $ fromLazyList [2,4,5]+       assertEqual Nil $ dropWhile (>=1) $ fromLazyList [2,4,5]++test_stripPrefix :: IO ()+test_stripPrefix =+    do assertEqual (Just Nil) $ stripPrefix Nil (Nil :: SL Int)+       assertEqual (Just $ 1 :! Nil) $ stripPrefix Nil (1 :! Nil)+       assertEqual (Just Nil) $ stripPrefix (1 :! Nil) (1 :! Nil)+       assertEqual (Just $ 3 :! Nil) $ stripPrefix (1 :! 2 :! Nil) (1 :! 2 :! 3 :! Nil)+       assertEqual Nothing $ stripPrefix (1 :! Nil) Nil++test_stripSuffix :: IO ()+test_stripSuffix =+    do assertEqual (Just Nil) $ stripSuffix Nil (Nil :: SL Int)+       assertEqual (Just $ 1 :! Nil) $ stripSuffix Nil (1 :! Nil)+       assertEqual (Just Nil) $ stripSuffix (1 :! Nil) (1 :! Nil)+       assertEqual (Just $ 1 :! Nil) $ stripSuffix (2 :! 3 :! Nil) (1 :! 2 :! 3 :! Nil)+       assertEqual Nothing $ stripSuffix (1 :! Nil) Nil++test_deleteIdx :: IO ()+test_deleteIdx =+    do assertEqual (1 :! Nil) $ deleteIdx (-5) (1 :! Nil)+       assertEqual (1 :! 3 :! Nil) $ deleteIdx 1 (1 :! 2 :! 3 :! Nil)+       assertEqual Nil $ deleteIdx 0 ("B" :! Nil)+       assertEqual (fromLazyList ["a","B","C","D","E"]) $+                   deleteIdx 5 (fromLazyList ["a","B","C","D","E","Q"])+       assertEqual (fromLazyList [1,3,2,4]) $+                    deleteIdx 4 (fromLazyList [1,3,2,4])++test_atIdx :: IO ()+test_atIdx =+    do assertEqual (Some 1) $ atIdx 0 (1 :! Nil)+       assertEqual None $ atIdx 6 (1 :! 2 :! 3 :! Nil)+       assertEqual None $ atIdx (-3) ("B" :! Nil)+       assertEqual (Some "a") $ atIdx 5 (fromLazyList ["g","q","s","u","xc","a"])++test_snoc :: IO ()+test_snoc =+    do assertEqual (True :! Nil) (snoc Nil True)+       assertEqual (False :! True :! Nil) (snoc (False :! Nil) True)++test_transpose :: IO ()+test_transpose =+    do assertEqual (f [[1,4],[2,5],[3,6]]) (transpose (f [[1,2,3],[4,5,6]]))+       assertEqual (f [[1,2,3],[4,5],[6]]) (transpose (f [[1,4],[2],[],[3,5,6]]))+    where+      f = fmap sl . sl++prop_difference :: SL Int -> SL Int -> Bool+prop_difference xs ys = (xs +!+ ys) \!\ xs == ys++test_delete :: IO ()+test_delete =+    do assertEqual (sl "bnana") (delete 'a' (sl "banana"))+       assertEqual Nil (delete 'a' Nil)++test_merge :: IO ()+test_merge =+    assertEqual (sl "abcdef" :: SL Char) (merge (sl "acde") (sl "abdf"))
+ test/StrictVector.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-name-shadowing -F -pgmF htfpp #-}+module StrictVector where++import Data.Option+import Data.StrictVector++import Control.Exception+import Test.Framework+import qualified Data.List as L+import qualified Data.Vector.Generic as VG++prop_groupBy :: [(Int,Int)] -> Bool+prop_groupBy l =+    let eq (_,x) (_,y) = x == y+        res1 = groupBy eq (fromList l)+        res2 = fmap fromList (fromList (L.groupBy eq l))+    in res2 == res1++-- prop_groupOn :: [(Int,Int)] -> Bool+-- prop_groupOn l =+--     let proj = snd+--         res1 = groupOn proj (fromList l)+--         res2 = fmap (second fromList) (fromList (L.groupOn proj l))+--     in res2 == res1++test_lookingAround :: IO ()+test_lookingAround =+    do assertEqual expected1 (f input1)+       assertEqual [] (f [])+       assertEqual [(Nothing,1,Nothing)] (f [1])+       assertEqual [(Nothing,1,Just 2),(Just 1,2,Nothing)] (f [1,2])+    where+      f :: [Int] -> [(Maybe Int, Int, Maybe Int)]+      f list = toList (lookAround (fromList list))+      input1 = [1,2,3]+      expected1 = [ (Nothing, 1, Just 2)+                  , (Just 1, 2, Just 3)+                  , (Just 2, 3, Nothing)+                  ]++test_uncons :: IO ()+test_uncons =+    let atoe :: Int+        atoe = 42+    in do assertEqual None (uncons $ fromList $ L.drop 1 [atoe])+          assertEqual (Some (atoe, fromList [5,2,3]))+                      (uncons $ fromList [atoe,5,2,3])++test_binarySearchL :: IO ()+test_binarySearchL =+    do assertEqual 0 (binarySearchL (flip compare 0) (fromList [0,1,2]))+       assertEqual 1 (binarySearchL (flip compare 1) (fromList [0,1,2]))+       assertEqual 1 (binarySearchL (flip compare 1) (fromList [0,1,1,2]))+       assertEqual 2 (binarySearchL (flip compare 2) (fromList [0,1,2]))+       assertEqual 3 (binarySearchL (flip compare 3) (fromList [0,1,2]))++test_binarySearchR :: IO ()+test_binarySearchR =+    do assertEqual 0 (binarySearchR (flip compare 0) (fromList [1,2,3]))+       assertEqual 1 (binarySearchR (flip compare 0) (fromList [0,1,2]))+       assertEqual 2 (binarySearchR (flip compare 1) (fromList [0,1,2]))+       assertEqual 3 (binarySearchR (flip compare 1) (fromList [0,1,1,2]))+       assertEqual 3 (binarySearchR (flip compare 2) (fromList [0,1,2]))+       assertEqual 3 (binarySearchR (flip compare 3) (fromList [0,1,2]))++test_fromListStrict :: IO ()+test_fromListStrict =+    do let err = ErrorCall "..."+       res <- try $ (VG.fromList [1,2,throw err] :: Vector Int) `seq` return ()+       assertEqual (Left err) res
+ test/StrictVector/Mutable.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module StrictVector.Mutable where++import Data.StrictVector.Mutable++import Control.Exception+import Test.Framework+import qualified Data.Vector.Generic.Mutable as VGM++test_replicateStrict :: IO ()+test_replicateStrict =+    do let err = ErrorCall "..."+       res <- try $ (VGM.replicate 10 (throw err :: ()) :: IO (IOVector ()))+       assertEqual (Left err) (res >> Right ())++test_writeStrict :: IO ()+test_writeStrict =+    do let err = ErrorCall "..."+       vec <- VGM.replicate 1 ()+       res <- try $ VGM.write (vec :: IOVector ()) 0 (throw err)+       assertEqual (Left err) res++test_setStrict :: IO ()+test_setStrict =+    do let err = ErrorCall "..."+       vec <- VGM.replicate 1 ()+       res <- try $ VGM.set (vec :: IOVector ()) (throw err)+       assertEqual (Left err) res