foundation 0.0.15 → 0.0.16

raw patch · 11 files changed

+126/−209 lines, 11 filesdep ~basementPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: basement

API changes (from Hackage documentation)

Files

• Foundation/Exception.hs +15/−0
• Foundation/Foreign/MemoryMap/Windows.hs +0/−1
• Foundation/List/ListN.hs +2/−175
• Foundation/Monad/Except.hs +48/−0
• Foundation/Monad/Reader.hs +9/−0
• Foundation/Primitive.hs +1/−1
• Foundation/Time/StopWatch.hs +24/−27
• benchs/BenchUtil/RefData.hs +6/−2
• benchs/Main.hs +16/−0
• foundation.cabal +4/−2
• tests/Test/Foundation/Primitive/BlockN.hs +1/−1

@@ -0,0 +1,15 @@+module Foundation.Exception+    ( finally+    , try+    , SomeException+    ) where++import Basement.Imports+import Control.Exception (Exception, SomeException)+import Foundation.Monad.Exception++finally :: MonadBracket m => m a -> m b -> m a+finally f g = generalBracket (pure ()) (\() a -> g >> pure a) (\() _ -> g) (const f)++try :: (MonadCatch m, Exception e) => m a -> m (Either e a)+try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))

@@ -9,7 +9,6 @@  import Basement.Compat.Base import Basement.Types.OffsetSize-import Basement.FinalPtr import Foundation.VFS import Foundation.Foreign.MemoryMap.Types 

@@ -9,179 +9,6 @@ -- -- Using this module is limited to GHC 7.10 and above. ---{-# LANGUAGE KindSignatures            #-}-{-# LANGUAGE DataKinds                 #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE TypeOperators             #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE UndecidableInstances      #-}-module Foundation.List.ListN-    ( ListN-    , toListN-    , unListN-    , length-    , create-    , createFrom-    , empty-    , singleton-    , uncons-    , cons-    , map-    , elem-    , foldl-    , append-    , minimum-    , maximum-    , head-    , tail-    , take-    , drop-    , zip, zip3, zip4, zip5-    , zipWith, zipWith3, zipWith4, zipWith5-    , replicateM-    ) where--import           Data.Proxy-import           Basement.Compat.Base-import           Basement.Nat-import           Foundation.Numerical-import qualified Prelude-import qualified Control.Monad as M (replicateM)--impossible :: a-impossible = error "ListN: internal error: the impossible happened"--newtype ListN (n :: Nat) a = ListN { unListN :: [a] }--toListN :: forall (n :: Nat) a . (KnownNat n, NatWithinBound Int n) => [a] -> Maybe (ListN n a)-toListN l-    | expected == Prelude.fromIntegral (Prelude.length l) = Just (ListN l)-    | otherwise                                           = Nothing-  where-    expected = natValInt (Proxy :: Proxy n)--replicateM :: forall (n :: Nat) m a . (n <= 0x100000, Monad m, KnownNat n) => m a -> m (ListN n a)-replicateM action = ListN <$> M.replicateM (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) action--uncons :: CmpNat n 0 ~ 'GT => ListN n a -> (a, ListN (n-1) a)-uncons (ListN (x:xs)) = (x, ListN xs)-uncons _ = impossible--cons :: a -> ListN n a -> ListN (n+1) a-cons a (ListN l) = ListN (a : l)--empty :: ListN 0 a-empty = ListN []--length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => ListN n a -> Int-length _ = natValInt (Proxy :: Proxy n)--create :: forall a (n :: Nat) . KnownNat n => (Integer -> a) -> ListN n a-create f = ListN $ Prelude.map f [0..(len-1)]-  where-    len = natVal (Proxy :: Proxy n)--createFrom :: forall a (n :: Nat) (start :: Nat) . (KnownNat n, KnownNat start)-           => Proxy start -> (Integer -> a) -> ListN n a-createFrom p f = ListN $ Prelude.map f [idx..(idx+len)]-  where-    len = natVal (Proxy :: Proxy n)-    idx = natVal p--singleton :: a -> ListN 1 a-singleton a = ListN [a]--elem :: Eq a => a -> ListN n a -> Bool-elem a (ListN l) = Prelude.elem a l--append :: ListN n a -> ListN m a -> ListN (n+m) a-append (ListN l1) (ListN l2) = ListN (l1 <> l2)--maximum :: (Ord a, CmpNat n 0 ~ 'GT) => ListN n a -> a-maximum (ListN l) = Prelude.maximum l--minimum :: (Ord a, CmpNat n 0 ~ 'GT) => ListN n a -> a-minimum (ListN l) = Prelude.minimum l--head :: CmpNat n 0 ~ 'GT => ListN n a -> a-head (ListN (x:_)) = x-head _ = impossible--tail :: CmpNat n 0 ~ 'GT => ListN n a -> ListN (n-1) a-tail (ListN (_:xs)) = ListN xs-tail _ = impossible--take :: forall a (m :: Nat) (n :: Nat) . (KnownNat m, NatWithinBound Int m, m <= n) => ListN n a -> ListN m a-take (ListN l) = ListN (Prelude.take n l)-  where n = natValInt (Proxy :: Proxy m)--drop :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> ListN m a-drop (ListN l) = ListN (Prelude.drop n l)-  where n = natValInt (Proxy :: Proxy d)--map :: (a -> b) -> ListN n a -> ListN n b-map f (ListN l) = ListN (Prelude.map f l)--foldl :: (b -> a -> b) -> b -> ListN n a -> b-foldl f acc (ListN l) = Prelude.foldl f acc l--zip :: ListN n a -> ListN n b -> ListN n (a,b)-zip (ListN l1) (ListN l2) = ListN (Prelude.zip l1 l2)--zip3 :: ListN n a -> ListN n b -> ListN n c -> ListN n (a,b,c)-zip3 (ListN x1) (ListN x2) (ListN x3) = ListN (loop x1 x2 x3)-  where loop (l1:l1s) (l2:l2s) (l3:l3s) = (l1,l2,l3) : loop l1s l2s l3s-        loop []       _        _        = []-        loop _        _        _        = impossible--zip4 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n (a,b,c,d)-zip4 (ListN x1) (ListN x2) (ListN x3) (ListN x4) = ListN (loop x1 x2 x3 x4)-  where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) = (l1,l2,l3,l4) : loop l1s l2s l3s l4s-        loop []       _        _        _        = []-        loop _        _        _        _        = impossible--zip5 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n e -> ListN n (a,b,c,d,e)-zip5 (ListN x1) (ListN x2) (ListN x3) (ListN x4) (ListN x5) = ListN (loop x1 x2 x3 x4 x5)-  where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) (l5:l5s) = (l1,l2,l3,l4,l5) : loop l1s l2s l3s l4s l5s-        loop []       _        _        _        _        = []-        loop _        _        _        _        _        = impossible--zipWith :: (a -> b -> x) -> ListN n a -> ListN n b -> ListN n x-zipWith f (ListN (v1:vs)) (ListN (w1:ws)) = ListN (f v1 w1 : unListN (zipWith f (ListN vs) (ListN ws)))-zipWith _ (ListN [])       _ = ListN []-zipWith _ _                _ = impossible--zipWith3 :: (a -> b -> c -> x)-         -> ListN n a-         -> ListN n b-         -> ListN n c-         -> ListN n x-zipWith3 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) =-    ListN (f v1 w1 x1 : unListN (zipWith3 f (ListN vs) (ListN ws) (ListN xs)))-zipWith3 _ (ListN []) _       _ = ListN []-zipWith3 _ _          _       _ = impossible--zipWith4 :: (a -> b -> c -> d -> x)-         -> ListN n a-         -> ListN n b-         -> ListN n c-         -> ListN n d-         -> ListN n x-zipWith4 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) (ListN (y1:ys)) =-    ListN (f v1 w1 x1 y1 : unListN (zipWith4 f (ListN vs) (ListN ws) (ListN xs) (ListN ys)))-zipWith4 _ (ListN []) _       _       _ = ListN []-zipWith4 _ _          _       _       _ = impossible+module Foundation.List.ListN ( module X ) where -zipWith5 :: (a -> b -> c -> d -> e -> x)-         -> ListN n a-         -> ListN n b-         -> ListN n c-         -> ListN n d-         -> ListN n e-         -> ListN n x-zipWith5 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) (ListN (y1:ys)) (ListN (z1:zs)) =-    ListN (f v1 w1 x1 y1 z1 : unListN (zipWith5 f (ListN vs) (ListN ws) (ListN xs) (ListN ys) (ListN zs)))-zipWith5 _ (ListN []) _       _       _       _ = ListN []-zipWith5 _ _          _       _       _       _ = impossible+import Basement.Sized.List as X

@@ -0,0 +1,48 @@+{-# LANGUAGE TypeFamilies #-}+module Foundation.Monad.Except+    ( ExceptT(..)+    ) where++import Basement.Imports+import Foundation.Monad.Base+import Foundation.Monad.Reader++newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) }++instance Functor m => Functor (ExceptT e m) where+    fmap f = ExceptT . fmap (fmap f) . runExceptT++instance (Functor m, Monad m) => Applicative (ExceptT e m) where+    pure a = ExceptT $ pure (Right a)+    ExceptT f <*> ExceptT v = ExceptT $ do+        mf <- f+        case mf of+            Left e -> pure (Left e)+            Right k -> do+                mv <- v+                case mv of+                    Left e -> pure (Left e)+                    Right x -> pure (Right (k x))++instance Monad m => MonadFailure (ExceptT e m) where+    type Failure (ExceptT e m) = e+    mFail = ExceptT . pure . Left++instance Monad m => Monad (ExceptT e m) where+    return a = ExceptT $ return (Right a)+    m >>= k = ExceptT $ do+        a <- runExceptT m+        case a of+            Left e -> return (Left e)+            Right x -> runExceptT (k x)+    fail = ExceptT . fail++instance MonadReader m => MonadReader (ExceptT e m) where+    type ReaderContext (ExceptT e m) = ReaderContext m+    ask = ExceptT (Right <$> ask)++instance MonadTrans (ExceptT e) where+    lift f = ExceptT (Right <$> f)++instance MonadIO m => MonadIO (ExceptT e m) where+    liftIO f = ExceptT (Right <$> liftIO f)

@@ -13,6 +13,7 @@  import Basement.Compat.Base (($), (.), const) import Foundation.Monad.Base+import Foundation.Monad.Exception  class Monad m => MonadReader m where     type ReaderContext m@@ -54,6 +55,14 @@  instance MonadCatch m => MonadCatch (ReaderT r m) where     catch (ReaderT m) c = ReaderT $ \r -> m r `catch` (\e -> runReaderT (c e) r)++instance MonadBracket m => MonadBracket (ReaderT r m) where+    generalBracket acq cleanup cleanupExcept innerAction = do+        c <- ask+        lift $ generalBracket (runReaderT acq c)+                              (\a b -> runReaderT (cleanup a b) c)+                              (\a exn -> runReaderT (cleanupExcept a exn) c)+                              (\a -> runReaderT (innerAction a) c)  instance Monad m => MonadReader (ReaderT r m) where     type ReaderContext (ReaderT r m) = r

@@ -35,7 +35,7 @@      -- * Ascii     , Char7-    , AsciiString(..)+    , AsciiString     ) where  import Basement.PrimType

@@ -53,13 +53,12 @@ initPrecise :: (Word64, Word64) initPrecise = unsafePerformIO $ do     mti <- newPinned (sizeOfCSize size_MachTimebaseInfo)-    p   <- mutableGetAddr mti-    sysMacos_timebase_info (castPtr p)-    let p32 = castPtr p :: Ptr Word32-    !n <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_numer)-    !d <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_denom)-    mutableTouch mti-    pure (integralUpsize n, integralUpsize d)+    mutableWithPtr mti $ \p -> do+        sysMacos_timebase_info (castPtr p)+        let p32 = castPtr p :: Ptr Word32+        !n <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_numer)+        !d <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_denom)+        pure (integralUpsize n, integralUpsize d) {-# NOINLINE initPrecise #-} #endif @@ -70,15 +69,15 @@ startPrecise = do #if defined(mingw32_HOST_OS)     blk <- newPinned 16-    p   <- mutableGetAddr blk-    _ <- c_QueryPerformanceCounter (castPtr p `ptrPlus` 8)+    _ <- mutableWithPtr blk $ \p ->+        c_QueryPerformanceCounter (castPtr p `ptrPlus` 8)     pure (StopWatchPrecise blk) #elif defined(darwin_HOST_OS)     StopWatchPrecise <$> sysMacos_absolute_time #else     blk <- newPinned (sizeOfCSize (size_CTimeSpec + size_CTimeSpec))-    p   <- mutableGetAddr blk-    _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC (castPtr p `ptrPlusCSz` size_CTimeSpec)+    _err1 <- mutableWithPtr blk $ \p -> do+        sysTimeClockGetTime sysTime_CLOCK_MONOTONIC (castPtr p `ptrPlusCSz` size_CTimeSpec)     pure (StopWatchPrecise blk) #endif @@ -86,28 +85,26 @@ stopPrecise :: StopWatchPrecise -> IO NanoSeconds stopPrecise (StopWatchPrecise blk) = do #if defined(mingw32_HOST_OS)-    p <- mutableGetAddr blk-    _ <- c_QueryPerformanceCounter (castPtr p)-    let p64 = castPtr p :: Ptr Word64-    end   <- peek p64-    start <- peek (p64 `ptrPlus` 8)-    mutableTouch blk-    pure $ NanoSeconds ((end - start) * secondInNano `div` initPrecise)+    mutableWithPtr blk $ \p -> do+        _ <- c_QueryPerformanceCounter (castPtr p)+        let p64 = castPtr p :: Ptr Word64+        end   <- peek p64+        start <- peek (p64 `ptrPlus` 8)+        pure $ NanoSeconds ((end - start) * secondInNano `div` initPrecise) #elif defined(darwin_HOST_OS)     end <- sysMacos_absolute_time     pure $ NanoSeconds $ case initPrecise of         (1,1)         -> end - blk         (numer,denom) -> ((end - blk) * numer) `div` denom #else-    p <- mutableGetAddr blk-    _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC (castPtr p)-    let p64 = castPtr p :: Ptr Word64-    endSec    <- peek p64-    startSec  <- peek (p64 `ptrPlusCSz` size_CTimeSpec)-    endNSec   <- peek (p64 `ptrPlus` ofs_CTimeSpec_NanoSeconds)-    startNSec <- peek (p64 `ptrPlus` (sizeAsOffset (sizeOfCSize size_CTimeSpec) + ofs_CTimeSpec_NanoSeconds))-    mutableTouch blk-    pure $ NanoSeconds $ (endSec * secondInNano + endNSec) - (startSec * secondInNano + startNSec)+    mutableWithPtr blk $ \p -> do+        _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC (castPtr p)+        let p64 = castPtr p :: Ptr Word64+        endSec    <- peek p64+        startSec  <- peek (p64 `ptrPlusCSz` size_CTimeSpec)+        endNSec   <- peek (p64 `ptrPlus` ofs_CTimeSpec_NanoSeconds)+        startNSec <- peek (p64 `ptrPlus` (sizeAsOffset (sizeOfCSize size_CTimeSpec) + ofs_CTimeSpec_NanoSeconds))+        pure $ NanoSeconds $ (endSec * secondInNano + endNSec) - (startSec * secondInNano + startNSec) #endif  secondInNano :: Word64

@@ -11,10 +11,11 @@     , rdBytes20     , rdBytes200     , rdBytes2000+    , rdWord32     ) where -import Prelude (Char, cycle, take, ($))-import Data.Word (Word8)+import Prelude (Int, Char, cycle, take, ($))+import Data.Word (Word8, Word32)  rdLoremIpsum1 :: [Char] rdLoremIpsum1 = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nam ornare dui vitae porta varius. In quis diam sed felis elementum ultricies non sit amet lorem. Nullam ut erat varius lectus scelerisque iaculis sed eu leo. Vivamus gravida interdum elit suscipit tempus. Quisque at mauris ac sapien consequat feugiat. In varius interdum rhoncus. Etiam hendrerit pharetra consectetur. Pellentesque laoreet, nisi quis feugiat rhoncus, nisi ipsum tincidunt nulla, vel fermentum mauris nisl sed felis. Sed ac convallis nibh. Donec rutrum finibus odio et rhoncus. Suspendisse pulvinar ex ac fermentum fermentum. Nam dui dui, lobortis sit amet sapien sed, gravida sagittis magna. Vestibulum nec egestas dui, non efficitur lectus. Fusce vitae mattis sem, nec dignissim nibh. Sed ac tincidunt metus."@@ -42,3 +43,6 @@  rdBytes2000 :: [Word8] rdBytes2000 = take 2000 $ cycle [1..255]++rdWord32 :: Int -> [Word32]+rdWord32 n = Prelude.take n $ Prelude.cycle [1..255]

@@ -181,6 +181,7 @@     , benchFilter     , benchAll     , benchSort+    , benchSort32     ]   where     diffByteArray :: (UArray Word8 -> a)@@ -279,6 +280,21 @@             blockBench dat = sortBy compare dat             uarrayBench :: UArray Word8 -> UArray Word8             uarrayBench dat = sortBy compare dat+    +    benchSort32 = bgroup "Sort32" $ fmap (\n ->+        bgroup (show n) $ +            [ bench "Array_W32" $ whnf arrayBench (fromList $ rdWord32 n)+            , bench "UArray_W32" $ whnf uarrayBench (fromList $ rdWord32 n)+            , bench "Block_W32" $ whnf blockBench (fromList $ rdWord32 n)+            ]) [20, 200, 2000]+      where+            blockBench :: Block Word32 -> Block Word32+            blockBench dat = sortBy compare dat+            uarrayBench :: UArray Word32 -> UArray Word32+            uarrayBench dat = sortBy compare dat+            arrayBench :: Array Word32 -> Array Word32+            arrayBench dat = sortBy compare dat+  -------------------------------------------------------------------------- 

@@ -1,5 +1,5 @@ name:                foundation-version:             0.0.15+version:             0.0.16 synopsis:            Alternative prelude with batteries and no dependencies description:     A custom prelude with no dependencies apart from base.@@ -74,6 +74,7 @@                      Foundation.Class.Storable                      Foundation.Conduit                      Foundation.Conduit.Textual+                     Foundation.Exception                      Foundation.String                      Foundation.String.Read                      Foundation.String.Builder@@ -91,6 +92,7 @@                      Foundation.Primitive                      Foundation.List.DList                      Foundation.Monad+                     Foundation.Monad.Except                      Foundation.Monad.Reader                      Foundation.Monad.State                      Foundation.Network.IPv4@@ -190,7 +192,7 @@                       BangPatterns                       DeriveDataTypeable   build-depends:     base >= 4.7 && < 5-                   , basement == 0.0.2+                   , basement == 0.0.3                    , ghc-prim   -- FIXME add suport for armel mipsel   --  CPP-options: -DARCH_IS_LITTLE_ENDIAN

@@ -12,7 +12,7 @@ import           Foundation hiding (singleton, replicate, cons, uncons, elem) import           Basement.Nat import qualified Basement.Block as B-import           Basement.BlockN+import           Basement.Sized.Block import           Basement.From import           Foundation.Check