diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,29 @@ +## 0.0.17 + +* Add Terminal capabilities: ANSI Escape, UTF8 codepage initialization, get dimensions +* Checks: Output now has colors +* Hashable: Add Word128 & Word256 & Boxed Array instances +* Semigroup: Compatibility with GHC 8.4 +* Drop criterion for benchmark, now use Gauge +* Remove more UnboxedTuples from Foundation for easier loading with bytecode interpreter +* Reduce overhead of profiling common primitive operation like size and offset addition by + preventing auto-caf in abstraction module +* Optimise UTF8 validation +* Optimise String toList (allow fusion) +* Optimise String reversal +* Merge different version of lowlevel array algorithms with one backed by a class. +* Zn64/Zn : Add Num, Additive, Subtractive, NormalForm, Arbitrary instances + +## 0.0.16 + +* Re-organize type sized structure and add UVect and Vect +* Cleanup constraint in ListN, and add couple of combinators +* Add ExceptT +* Add some exception combinators (try,finally) that works with foundation classes. +* Tidy mutable algorithm for sorting removing redundant code +* Add primitive to convert Double/Float to Word64/Word32 +* Cleanup withPtr / getAddr code to be safer + ## 0.0.15 * Add Bits instance for Natural compat with 7.8 diff --git a/Foundation.hs b/Foundation.hs --- a/Foundation.hs +++ b/Foundation.hs @@ -101,6 +101,7 @@ , Prelude.fromIntegral , Prelude.realToFrac -- ** Monoids + , Basement.Compat.Semigroup.Semigroup , Monoid (..) , (<>) -- ** Collection @@ -186,6 +187,7 @@ import Basement.Environment (getArgs) import Basement.Compat.NumLiteral import Basement.Compat.Natural +import qualified Basement.Compat.Semigroup import qualified Data.Maybe import qualified Data.Either diff --git a/Foundation/Array/Bitmap.hs b/Foundation/Array/Bitmap.hs --- a/Foundation/Array/Bitmap.hs +++ b/Foundation/Array/Bitmap.hs @@ -33,6 +33,7 @@ import qualified Basement.UArray as A import Basement.UArray.Mutable (MUArray) import Basement.Compat.Bifunctor (first, second, bimap) +import Basement.Compat.Semigroup import Basement.Exception import Basement.Compat.Base import Basement.Types.OffsetSize @@ -63,6 +64,8 @@ (==) = equal instance Ord Bitmap where compare = vCompare +instance Semigroup Bitmap where + (<>) = append instance Monoid Bitmap where mempty = empty mappend = append diff --git a/Foundation/Array/Chunked/Unboxed.hs b/Foundation/Array/Chunked/Unboxed.hs --- a/Foundation/Array/Chunked/Unboxed.hs +++ b/Foundation/Array/Chunked/Unboxed.hs @@ -24,6 +24,7 @@ import Basement.UArray (UArray) import qualified Basement.UArray as U import Basement.Compat.Bifunctor +import Basement.Compat.Semigroup import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.PrimType @@ -42,6 +43,8 @@ instance NormalForm (ChunkedUArray ty) where toNormalForm (ChunkedUArray spine) = toNormalForm spine +instance Semigroup (ChunkedUArray a) where + (<>) = append instance Monoid (ChunkedUArray a) where mempty = empty mappend = append diff --git a/Foundation/Check/Arbitrary.hs b/Foundation/Check/Arbitrary.hs --- a/Foundation/Check/Arbitrary.hs +++ b/Foundation/Check/Arbitrary.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} module Foundation.Check.Arbitrary ( Arbitrary(..) , frequency @@ -19,6 +20,9 @@ import qualified Basement.Types.Char7 as Char7 import Basement.Types.Word128 (Word128(..)) import Basement.Types.Word256 (Word256(..)) +#if __GLASGOW_HASKELL__ >= 710 +import qualified Basement.Sized.List as ListN +#endif import Foundation.Check.Gen import Foundation.Random import Foundation.Bits @@ -113,6 +117,10 @@ instance Arbitrary a => Arbitrary [a] where arbitrary = genWithParams $ \params -> fromList <$> (genMax (genMaxSizeArray params) >>= \i -> replicateM (integralCast i) arbitrary) +#if __GLASGOW_HASKELL__ >= 710 +instance (Arbitrary a, KnownNat n, NatWithinBound Int n) => Arbitrary (ListN.ListN n a) where + arbitrary = ListN.replicateM arbitrary +#endif arbitraryInteger :: Gen Integer arbitraryInteger = diff --git a/Foundation/Check/Main.hs b/Foundation/Check/Main.hs --- a/Foundation/Check/Main.hs +++ b/Foundation/Check/Main.hs @@ -17,8 +17,10 @@ import Basement.Imports import Basement.IntegralConv +import Basement.Bounded import Basement.Types.OffsetSize -import Foundation.System.Info (os, OS(..)) +import qualified Basement.Terminal.ANSI as ANSI +import qualified Basement.Terminal as Terminal import Foundation.Collection import Foundation.Numerical import Foundation.IO.Terminal @@ -88,6 +90,8 @@ -- | Run tests defaultMain :: Test -> IO () defaultMain allTestRoot = do + Terminal.initialize + -- parse arguments ecfg <- flip parseArgs defaultConfig <$> getArgs cfg <- case ecfg of @@ -117,10 +121,10 @@ -- display a summary of the result and use the right exit code summary cfg | kos > 0 = do - putStrLn $ "Failed " <> show kos <> " out of " <> show tot + putStrLn $ red <> "Failed " <> show kos <> " out of " <> show tot <> reset exitFailure | otherwise = do - putStrLn $ "Succeed " <> show oks <> " test(s)" + putStrLn $ green <> "Succeed " <> show oks <> " test(s)" <> reset exitSuccess where oks = testPassed cfg @@ -197,19 +201,25 @@ , if nb == 1 then " test)" else " tests)" ] +unicodeEnabled :: Bool +unicodeEnabled = True + successString :: String -successString = case os of - Right Linux -> " ✓ " - Right OSX -> " ✓ " - _ -> "[SUCCESS]" +successString + | unicodeEnabled = green <> " ✓ " <> reset + | otherwise = green <> "[SUCCESS] " <> reset {-# NOINLINE successString #-} failureString :: String -failureString = case os of - Right Linux -> " ✗ " - Right OSX -> " ✗ " - _ -> "[ ERROR ]" +failureString + | unicodeEnabled = red <> " ✗ " <> reset + | otherwise = red <> "[ ERROR ] " <> reset {-# NOINLINE failureString #-} + +reset, green, red :: ANSI.Escape +reset = ANSI.sgrReset +green = ANSI.sgrForeground (zn64 2) True +red = ANSI.sgrForeground (zn64 1) True displayPropertyFailed :: String -> CountOf TestResult -> String -> CheckMain () displayPropertyFailed name (CountOf nb) w = do diff --git a/Foundation/Hashing/Hashable.hs b/Foundation/Hashing/Hashable.hs --- a/Foundation/Hashing/Hashable.hs +++ b/Foundation/Hashing/Hashable.hs @@ -12,15 +12,17 @@ ( Hashable(..) ) where -import Basement.Compat.Base -import Basement.Compat.Natural -import Basement.IntegralConv -import Basement.Numerical.Multiplicative -import Foundation.Array -import Foundation.Tuple -import Foundation.String -import Foundation.Collection.Foldable -import Foundation.Hashing.Hasher +import Basement.Imports +import Basement.Compat.Natural +import Basement.Types.Word128 +import Basement.Types.Word256 +import Basement.IntegralConv +import Basement.Numerical.Multiplicative +import qualified Basement.BoxedArray as A +import Foundation.Tuple +import Foundation.String +import Foundation.Collection.Foldable +import Foundation.Hashing.Hasher -- | Type with the ability to be hashed -- @@ -42,6 +44,10 @@ hashMix w = hashMix32 w instance Hashable Word64 where hashMix w = hashMix64 w +instance Hashable Word128 where + hashMix (Word128 w1 w2) = hashMix64 w2 . hashMix64 w1 +instance Hashable Word256 where + hashMix (Word256 w1 w2 w3 w4) = hashMix64 w4 . hashMix64 w3 . hashMix64 w2 . hashMix64 w1 instance Hashable Natural where hashMix n iacc | n == 0 = hashMix8 0 iacc @@ -77,8 +83,8 @@ -- collection type instances instance PrimType a => Hashable (UArray a) where hashMix ba = hashMixBytes ba ---instance Hashable a => Hashable (Array a) where --- hashMix arr st = foldl' (flip hashMix) st arr +instance Hashable a => Hashable (A.Array a) where + hashMix arr st = A.foldl' (flip hashMix) st arr -- combined instances instance Hashable a => Hashable [a] where diff --git a/Foundation/Hashing/Hasher.hs b/Foundation/Hashing/Hasher.hs --- a/Foundation/Hashing/Hasher.hs +++ b/Foundation/Hashing/Hasher.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE UnboxedTuples #-} module Foundation.Hashing.Hasher ( Hasher(..) ) where @@ -40,35 +39,26 @@ -- | Mix a Word16 into the state and return the new state hashMix16 :: Word16 -> st -> st hashMix16 w st = hashMix8 w2 $ hashMix8 w1 st - where (# !w1, !w2 #) = unWord16 w + where + !w1 = integralDownsize (w `unsafeShiftR` 8) + !w2 = integralDownsize w -- | Mix a Word32 into the state and return the new state hashMix32 :: Word32 -> st -> st hashMix32 w st = hashMix8 w4 $ hashMix8 w3 $ hashMix8 w2 $ hashMix8 w1 st - where (# !w1, !w2, !w3, !w4 #) = unWord32 w + where + !w1 = integralDownsize (w `unsafeShiftR` 24) + !w2 = integralDownsize (w `unsafeShiftR` 16) + !w3 = integralDownsize (w `unsafeShiftR` 8) + !w4 = integralDownsize w -- | Mix a Word64 into the state and return the new state hashMix64 :: Word64 -> st -> st hashMix64 w st = hashMix32 w2 $ hashMix32 w1 st - where (# !w1, !w2 #) = unWord64_32 w + where + !w1 = integralDownsize (w `unsafeShiftR` 32) + !w2 = integralDownsize w -- | Mix an arbitrary sized unboxed array and return the new state hashMixBytes :: A.PrimType e => UArray e -> st -> st hashMixBytes ba st = A.foldl' (flip hashMix8) st (A.unsafeRecast ba) - -unWord16 :: Word16 -> (# Word8, Word8 #) -unWord16 w = (# integralDownsize (w `unsafeShiftR` 8) - , integralDownsize w #) -{-# INLINE unWord16 #-} - -unWord32 :: Word32 -> (# Word8, Word8, Word8, Word8 #) -unWord32 w = (# integralDownsize (w `unsafeShiftR` 24) - , integralDownsize (w `unsafeShiftR` 16) - , integralDownsize (w `unsafeShiftR` 8) - , integralDownsize w #) -{-# INLINE unWord32 #-} - -unWord64_32 :: Word64 -> (# Word32, Word32 #) -unWord64_32 w = (# integralDownsize (w `unsafeShiftR` 32) - , integralDownsize w #) -{-# INLINE unWord64_32 #-} diff --git a/Foundation/Hashing/SipHash.hs b/Foundation/Hashing/SipHash.hs --- a/Foundation/Hashing/SipHash.hs +++ b/Foundation/Hashing/SipHash.hs @@ -10,7 +10,6 @@ -- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} module Foundation.Hashing.SipHash ( SipKey(..) , SipHash(..) @@ -93,20 +92,20 @@ (k0 `xor` 0x6c7967656e657261) (k1 `xor` 0x7465646279746573) -mix8Prim :: Int -> Word8 -> InternalState -> SipIncremental -> (# InternalState, SipIncremental #) +mix8Prim :: Int -> Word8 -> InternalState -> SipIncremental -> (InternalState, SipIncremental) mix8Prim !c !w !ist !incremental = case incremental of - SipIncremental7 acc -> (# process c ist ((acc `unsafeShiftL` 8) .|. Prelude.fromIntegral w), SipIncremental0 #) + SipIncremental7 acc -> (process c ist ((acc `unsafeShiftL` 8) .|. Prelude.fromIntegral w), SipIncremental0) SipIncremental6 acc -> doAcc SipIncremental7 acc SipIncremental5 acc -> doAcc SipIncremental6 acc SipIncremental4 acc -> doAcc SipIncremental5 acc SipIncremental3 acc -> doAcc SipIncremental4 acc SipIncremental2 acc -> doAcc SipIncremental3 acc SipIncremental1 acc -> doAcc SipIncremental2 acc - SipIncremental0 -> (# ist, SipIncremental1 $ Prelude.fromIntegral w #) + SipIncremental0 -> (ist, SipIncremental1 $ Prelude.fromIntegral w) where doAcc constr acc = - (# ist , constr ((acc .<<. 8) .|. Prelude.fromIntegral w) #) + (ist , constr ((acc .<<. 8) .|. Prelude.fromIntegral w)) mix8 :: Int -> Word8 -> Sip -> Sip mix8 !c !w (Sip ist incremental len) = @@ -205,7 +204,7 @@ loop8 !st !incr !ofs !l = loop1 st incr ofs l loop1 !st !incr !ofs !l = case l - 1 of Nothing -> Sip st incr (currentLen + totalLen) - Just l1 -> let (# st', incr' #) = mix8Prim c (primBaIndex ba ofs) st incr + Just l1 -> let (!st', !incr') = mix8Prim c (primBaIndex ba ofs) st incr in loop1 st' incr' (ofs + Offset 1) l1 to64 :: Int -> Word8 -> Word64 @@ -231,7 +230,7 @@ loop8 !st !incr !ofs !l = loop1 st incr ofs l loop1 !st !incr !ofs !l = case l - 1 of Nothing -> Sip st incr (currentLen + totalLen) - Just l1 -> let (# st', incr' #) = mix8Prim c (primAddrIndex ptr ofs) st incr + Just l1 -> let (!st', !incr') = mix8Prim c (primAddrIndex ptr ofs) st incr in loop1 st' incr' (ofs + Offset 1) l1 doRound :: InternalState -> InternalState diff --git a/Foundation/List/DList.hs b/Foundation/List/DList.hs --- a/Foundation/List/DList.hs +++ b/Foundation/List/DList.hs @@ -12,8 +12,9 @@ ) where import Basement.Compat.Base -import Foundation.Collection +import Basement.Compat.Semigroup import Basement.Compat.Bifunctor +import Foundation.Collection newtype DList a = DList { unDList :: [a] -> [a] } deriving (Typeable) @@ -29,9 +30,11 @@ instance IsList (DList a) where type Item (DList a) = a - fromList = DList . (<>) + fromList = DList . (Basement.Compat.Semigroup.<>) toList = flip unDList [] +instance Semigroup (DList a) where + (<>) dl1 dl2 = DList $ unDList dl1 . unDList dl2 instance Monoid (DList a) where mempty = DList id mappend dl1 dl2 = DList $ unDList dl1 . unDList dl2 diff --git a/Foundation/String/Builder.hs b/Foundation/String/Builder.hs --- a/Foundation/String/Builder.hs +++ b/Foundation/String/Builder.hs @@ -17,7 +17,7 @@ ) where import Basement.Compat.Base ---import Basement.Compat.Semigroup +import Basement.Compat.Semigroup import Basement.String (String) import qualified Basement.String as S @@ -26,9 +26,8 @@ instance IsString Builder where fromString = E . fromString ---instance Semigroup Builder where --- (<>) = append - +instance Semigroup Builder where + (<>) = append instance Monoid Builder where mempty = empty mappend = append diff --git a/Foundation/System/Bindings/Posix.hsc b/Foundation/System/Bindings/Posix.hsc --- a/Foundation/System/Bindings/Posix.hsc +++ b/Foundation/System/Bindings/Posix.hsc @@ -11,6 +11,7 @@ -- Functions defined by the POSIX standards -- ----------------------------------------------------------------------------- +{-# LANGUAGE CApiFFI #-} {-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Posix where @@ -348,9 +349,9 @@ foreign import ccall unsafe "close" sysPosixClose :: CFd -> IO CInt -foreign import ccall unsafe "fcntl" +foreign import capi "fcntl.h fcntl" sysPosixFnctlNoArg :: CFd -> CInt -> IO CInt -foreign import ccall unsafe "fcntl" +foreign import capi "fcntl.h fcntl" sysPosixFnctlPtr :: CFd -> CInt -> Ptr a -> IO CInt foreign import ccall unsafe "ftruncate" diff --git a/Foundation/UUID.hs b/Foundation/UUID.hs --- a/Foundation/UUID.hs +++ b/Foundation/UUID.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/Foundation/VFS/FilePath.hs b/Foundation/VFS/FilePath.hs --- a/Foundation/VFS/FilePath.hs +++ b/Foundation/VFS/FilePath.hs @@ -35,6 +35,7 @@ ) where import Basement.Compat.Base +import Basement.Compat.Semigroup import Foundation.Collection import Foundation.Array import Foundation.String (Encoding(..), ValidationFailure, toBytes, fromBytes, String) @@ -184,9 +185,11 @@ hasContigueSeparators (x1:x2:xs) = (isSeparator x1 && x1 == x2) || hasContigueSeparators xs +instance Semigroup FileName where + (<>) (FileName a) (FileName b) = FileName $ a `mappend` b instance Monoid FileName where - mempty = FileName mempty - mappend (FileName a) (FileName b) = FileName $ a `mappend` b + mempty = FileName mempty + mappend (FileName a) (FileName b) = FileName $ a `mappend` b instance Path FilePath where type PathEnt FilePath = FileName diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -16,6 +16,11 @@ * [Foundation on stackage](https://www.stackage.org/package/foundation) * [Foundation on hackage](https://hackage.haskell.org/package/foundation) +Discuss: + +* [FP Chat](https://fpchat-invite.herokuapp.com) `#haskell-foundation` channel +* [Gitter](https://gitter.im/haskell-foundation/foundation) + Goals ===== diff --git a/benchs/BenchUtil/Common.hs b/benchs/BenchUtil/Common.hs --- a/benchs/BenchUtil/Common.hs +++ b/benchs/BenchUtil/Common.hs @@ -12,8 +12,8 @@ , nf ) where -import Criterion.Main hiding (bgroup, bench) -import qualified Criterion.Main as C +import Gauge.Main hiding (bgroup, bench) +import qualified Gauge.Main as C import Foundation fbench = bench "foundation" diff --git a/foundation.cabal b/foundation.cabal --- a/foundation.cabal +++ b/foundation.cabal @@ -1,5 +1,5 @@ name: foundation -version: 0.0.16 +version: 0.0.17 synopsis: Alternative prelude with batteries and no dependencies description: A custom prelude with no dependencies apart from base. @@ -192,7 +192,7 @@ BangPatterns DeriveDataTypeable build-depends: base >= 4.7 && < 5 - , basement == 0.0.3 + , basement == 0.0.4 , ghc-prim -- FIXME add suport for armel mipsel -- CPP-options: -DARCH_IS_LITTLE_ENDIAN @@ -274,7 +274,7 @@ if flag(minimal-deps) || impl(ghc < 7.10) buildable: False else - build-depends: base >= 4, criterion, basement, foundation + build-depends: base >= 4, gauge, basement, foundation if flag(bench-all) cpp-options: -DBENCH_ALL build-depends: text, attoparsec, vector, bytestring diff --git a/tests/Test/Foundation/Primitive/BlockN.hs b/tests/Test/Foundation/Primitive/BlockN.hs --- a/tests/Test/Foundation/Primitive/BlockN.hs +++ b/tests/Test/Foundation/Primitive/BlockN.hs @@ -11,6 +11,7 @@ import Data.Proxy (Proxy(..)) import Foundation hiding (singleton, replicate, cons, uncons, elem) import Basement.Nat +import Basement.Types.OffsetSize import qualified Basement.Block as B import Basement.Sized.Block import Basement.From