diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +## 0.0.20 + +* Reduce algorithm duplication between native and foreign backend +* Improve Unicode cases algorithm and increase testing +* Add CSV Builder +* Add a BitOps & FiniteBitOps classes to have better types than the Data.Bits.Bits class +* Improve BlockN operations +* Improve ListN operations +* Allow compilation with gauge 0.1 +* Add support for [haskell-ci](https://github.com/vincenthz/haskell-ci) + ## 0.0.19 * Add Block, UArray, String Builder diff --git a/Foundation/Array/Bitmap.hs b/Foundation/Array/Bitmap.hs --- a/Foundation/Array/Bitmap.hs +++ b/Foundation/Array/Bitmap.hs @@ -39,6 +39,7 @@ import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.Monad + import qualified Foundation.Collection as C import Foundation.Numerical import Data.Bits @@ -146,6 +147,8 @@ mutUnsafeRead = unsafeRead mutWrite = write mutRead = read + + bitmapIndex :: Offset Bool -> (Offset Word32, Int) bitmapIndex (Offset !i) = (Offset (i .>>. shiftPerTy), i .&. maskPerTy) diff --git a/Foundation/Check.hs b/Foundation/Check.hs --- a/Foundation/Check.hs +++ b/Foundation/Check.hs @@ -26,6 +26,7 @@ , IsProperty(..) , (===) , propertyCompare + , propertyCompareWith , propertyAnd , propertyFail , forAll diff --git a/Foundation/Check/Main.hs b/Foundation/Check/Main.hs --- a/Foundation/Check/Main.hs +++ b/Foundation/Check/Main.hs @@ -34,7 +34,6 @@ import Foundation.Random import Foundation.Monad import Foundation.Monad.State -import Control.Monad (when) import Data.Maybe (catMaybes) nbFail :: TestResult -> HasFailures @@ -273,8 +272,10 @@ then return (GroupResult name 0 (planValidations st) []) else do displayCurrent name - forM_ fails $ \f -> - liftIO $ putStrLn $ show f + forM_ fails $ \(PropertyResult name' nb r) -> + case r of + PropertySuccess -> whenVerbose $ displayPropertySucceed (name <> ": " <> name') nb + PropertyFailed w -> whenErrorOnly $ displayPropertyFailed (name <> ": " <> name') nb w return (GroupResult name (length fails) (planValidations st) fails) testProperty :: String -> Property -> CheckMain TestResult diff --git a/Foundation/Check/Property.hs b/Foundation/Check/Property.hs --- a/Foundation/Check/Property.hs +++ b/Foundation/Check/Property.hs @@ -12,6 +12,7 @@ , forAll , (===) , propertyCompare + , propertyCompareWith , propertyAnd , propertyFail ) where @@ -92,9 +93,22 @@ -> a -- ^ value left of the operator -> a -- ^ value right of the operator -> PropertyCheck -propertyCompare name op a b = - let sa = pretty a Proxy - sb = pretty b Proxy +propertyCompare name op = propertyCompareWith name op (flip pretty Proxy) + +-- | A property that check for a specific comparaison of its 2 members. +-- +-- This is equivalent to `===` but with `compare` and a given method to +-- pretty print the values. +-- +propertyCompareWith :: String -- ^ name of the function used for comparaison, e.g. (<) + -> (a -> a -> Bool) -- ^ function used for value comparaison + -> (a -> String) -- ^ function used to pretty print the values + -> a -- ^ value left of the operator + -> a -- ^ value right of the operator + -> PropertyCheck +propertyCompareWith name op display a b = + let sa = display a + sb = display b in PropertyBinaryOp (a `op` b) name sa sb -- | A conjuctive property composed of 2 properties that need to pass diff --git a/Foundation/Collection/Copy.hs b/Foundation/Collection/Copy.hs --- a/Foundation/Collection/Copy.hs +++ b/Foundation/Collection/Copy.hs @@ -1,14 +1,24 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} + module Foundation.Collection.Copy ( Copy(..) ) where import GHC.ST (runST) import Basement.Compat.Base ((>>=)) +import Basement.Nat +import Basement.Types.OffsetSize import qualified Basement.Block as BLK import qualified Basement.UArray as UA import qualified Basement.BoxedArray as BA import qualified Basement.String as S +#if MIN_VERSION_base(4,9,0) +import qualified Basement.Sized.Block as BLKN +import qualified Basement.Sized.List as LN +#endif + class Copy a where copy :: a -> a instance Copy [ty] where @@ -21,3 +31,10 @@ copy = BA.copy instance Copy S.String where copy = S.copy + +#if MIN_VERSION_base(4,9,0) +instance Copy (LN.ListN n ty) where + copy a = a +instance (Countable ty n, UA.PrimType ty, KnownNat n) => Copy (BLKN.BlockN n ty) where + copy blk = runST (BLKN.thaw blk >>= BLKN.freeze) +#endif diff --git a/Foundation/Collection/Element.hs b/Foundation/Collection/Element.hs --- a/Foundation/Collection/Element.hs +++ b/Foundation/Collection/Element.hs @@ -5,6 +5,9 @@ -- Stability : experimental -- Portability : portable -- + +{-# LANGUAGE CPP #-} + module Foundation.Collection.Element ( Element ) where @@ -18,6 +21,11 @@ import Basement.Types.Char7 (Char7) import Basement.NonEmpty +#if MIN_VERSION_base(4,9,0) +import Basement.Sized.Block (BlockN) +import Basement.Sized.List (ListN) +#endif + -- | Element type of a collection type family Element container type instance Element [a] = a @@ -27,3 +35,8 @@ type instance Element String = Char type instance Element AsciiString = Char7 type instance Element (NonEmpty a) = Element a + +#if MIN_VERSION_base(4,9,0) +type instance Element (BlockN n ty) = ty +type instance Element (ListN n a) = a +#endif diff --git a/Foundation/Collection/Foldable.hs b/Foundation/Collection/Foldable.hs --- a/Foundation/Collection/Foldable.hs +++ b/Foundation/Collection/Foldable.hs @@ -7,6 +7,14 @@ -- -- A mono-morphic re-thinking of the Foldable class -- + +{-# LANGUAGE CPP #-} + +#if MIN_VERSION_base(4,9,0) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +#endif + module Foundation.Collection.Foldable ( Foldable(..) , Fold1able(..) @@ -15,11 +23,17 @@ import Basement.Compat.Base import Foundation.Collection.Element import Basement.NonEmpty +import Basement.Nat import qualified Data.List import qualified Basement.UArray as UV import qualified Basement.Block as BLK import qualified Basement.BoxedArray as BA +#if MIN_VERSION_base(4,9,0) +import qualified Basement.Sized.List as LN +import qualified Basement.Sized.Block as BLKN +#endif + -- | Give the ability to fold a collection on itself class Foldable collection where -- | Left-associative fold of a structure. @@ -74,12 +88,22 @@ foldr = BLK.foldr foldl' = BLK.foldl' +#if MIN_VERSION_base(4,9,0) +instance Foldable (LN.ListN n a) where + foldr = LN.foldr + foldl' = LN.foldl' +instance UV.PrimType ty => Foldable (BLKN.BlockN n ty) where + foldr = BLKN.foldr + foldl' = BLKN.foldl' +#endif + ---------------------------- -- Fold1able instances ---------------------------- + instance Fold1able [a] where - foldr1 f = Data.List.foldr1 f . getNonEmpty - foldl1' f = Data.List.foldl1' f . getNonEmpty + foldr1 f = Data.List.foldr1 f . getNonEmpty + foldl1' f = Data.List.foldl1' f . getNonEmpty instance UV.PrimType ty => Fold1able (UV.UArray ty) where foldr1 = UV.foldr1 @@ -90,3 +114,9 @@ instance UV.PrimType ty => Fold1able (BLK.Block ty) where foldr1 = BLK.foldr1 foldl1' = BLK.foldl1' + +#if MIN_VERSION_base(4,9,0) +instance (1 <= n) => Fold1able (LN.ListN n a) where + foldr1 f = LN.foldr1 f . getNonEmpty + foldl1' f = LN.foldl1' f . getNonEmpty +#endif diff --git a/Foundation/Collection/Indexed.hs b/Foundation/Collection/Indexed.hs --- a/Foundation/Collection/Indexed.hs +++ b/Foundation/Collection/Indexed.hs @@ -5,12 +5,20 @@ -- Stability : experimental -- Portability : portable -- -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} + +#if MIN_VERSION_base(4,9,0) +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +#endif + module Foundation.Collection.Indexed ( IndexedCollection(..) ) where import Basement.Compat.Base +import Basement.Numerical.Additive ((+)) import Basement.Types.OffsetSize import Foundation.Collection.Element import qualified Data.List @@ -20,6 +28,12 @@ import qualified Basement.Exception as A import qualified Basement.String as S +#if MIN_VERSION_base(4,9,0) +import qualified Basement.Sized.Block as BLKN +import qualified Basement.Sized.List as LN +import Basement.Nat +#endif + -- | Collection of elements that can indexed by int class IndexedCollection c where (!) :: c -> Offset (Element c) -> Maybe (Element c) @@ -36,14 +50,14 @@ instance UV.PrimType ty => IndexedCollection (BLK.Block ty) where (!) l n | A.isOutOfBound n (BLK.length l) = Nothing - | otherwise = Just $ BLK.index l n + | otherwise = Just $ BLK.index l n findIndex predicate c = loop 0 where !len = BLK.length c loop i | i .==# len = Nothing | predicate (BLK.unsafeIndex c i) = Just i - | otherwise = Nothing + | otherwise = loop (i + 1) instance UV.PrimType ty => IndexedCollection (UV.UArray ty) where (!) l n @@ -72,3 +86,29 @@ instance IndexedCollection S.String where (!) = S.index findIndex = S.findIndex + +#if MIN_VERSION_base(4,9,0) +instance (NatWithinBound Int n, KnownNat n) => IndexedCollection (LN.ListN n a) where + (!) c off + | A.isOutOfBound off (LN.length c) = Nothing + | otherwise = Just $ LN.index c off + findIndex predicate c = loop 0 + where + !len = LN.length c + loop i + | i .==# len = Nothing + | predicate (LN.index c i) = Just i + | otherwise = loop (i + 1) + +instance (NatWithinBound (CountOf ty) n, KnownNat n, UV.PrimType ty) => IndexedCollection (BLKN.BlockN n ty) where + (!) c off + | A.isOutOfBound off (BLKN.length c) = Nothing + | otherwise = Just $ BLKN.index c off + findIndex predicate c = loop 0 + where + !len = BLKN.length c + loop i + | i .==# len = Nothing + | predicate (BLKN.index c i) = Just i + | otherwise = loop (i + 1) +#endif diff --git a/Foundation/Collection/Sequential.hs b/Foundation/Collection/Sequential.hs --- a/Foundation/Collection/Sequential.hs +++ b/Foundation/Collection/Sequential.hs @@ -76,11 +76,11 @@ break :: (Element c -> Bool) -> c -> (c,c) break predicate = span (not . predicate) - -- | Split a collection when the predicate return true + -- | Split a collection when the predicate return true starting from the end of the collection breakEnd :: (Element c -> Bool) -> c -> (c,c) breakEnd predicate = spanEnd (not . predicate) - -- | Split a collection when the predicate return true starting from the end of the collection + -- | Split a collection at the given element breakElem :: Eq (Element c) => Element c -> c -> (c,c) breakElem c = break (== c) @@ -116,7 +116,7 @@ -- | Filter all the elements that satisfy the predicate filter :: (Element c -> Bool) -> c -> c - -- | Partition the elements thtat satisfy the predicate and those that don't + -- | Partition the elements that satisfy the predicate and those that don't partition :: (Element c -> Bool) -> c -> (c,c) partition predicate c = (filter predicate c, filter (not . predicate) c) diff --git a/Foundation/Format/CSV.hs b/Foundation/Format/CSV.hs new file mode 100644 --- /dev/null +++ b/Foundation/Format/CSV.hs @@ -0,0 +1,232 @@ +-- | +-- Module : Foundation.Format.CSV +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- +-- Provies the support for Comma Separated Value + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Foundation.Format.CSV + (-- * CSV + CSV + + -- ** Builder + -- ** String Bulider + , csvStringBuilder + , rowStringBuilder + , fieldStringBuilder + -- ** Block Builder + , csvBlockBuilder + , rowBlockBuilder + , fieldBlockBuilder + -- ** Conduit + , rowC + -- * Row + , Row + , ToRow(..) + -- * Field + , Field(..) + , Escaping(..) + , ToField(..) + -- ** helpers + , integral + , float + , string + ) where + +import Basement.Imports -- hiding (throw) +import Basement.BoxedArray (Array) +import Basement.NormalForm (NormalForm(..)) +import Basement.From (Into, into) +import Basement.String (String, replace, any, elem) +import qualified Basement.String as String (singleton) +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) +import Basement.Types.OffsetSize (Offset, CountOf) +import Foundation.Collection.Element (Element) +import Foundation.Collection.Collection (Collection, nonEmpty_) +import Foundation.Collection.Sequential (Sequential(intersperse)) +import Foundation.Collection.Indexed (IndexedCollection) +import Foundation.Check.Arbitrary (Arbitrary(..), frequency) +import Foundation.Conduit.Internal + +import qualified Foundation.String.Builder as String +import Basement.Block (Block) +import qualified Basement.Block.Builder as Block + +import GHC.ST (runST) + +-- | CSV field +data Field + = FieldInteger Integer + | FieldDouble Double + | FieldString String Escaping + deriving (Eq, Show, Typeable) +instance NormalForm Field where + toNormalForm (FieldInteger i) = toNormalForm i + toNormalForm (FieldDouble d) = toNormalForm d + toNormalForm (FieldString s e) = toNormalForm s `seq` toNormalForm e +instance Arbitrary Field where + arbitrary = frequency $ nonEmpty_ [ (1, FieldInteger <$> arbitrary) + , (1, FieldDouble <$> arbitrary) + , (3, string <$> arbitrary) + ] + +data Escaping = NoEscape | Escape | DoubleEscape + deriving (Eq, Ord, Enum, Bounded, Show, Typeable) +instance NormalForm Escaping where + toNormalForm !_ = () + +class ToField a where + toField :: a -> Field +instance ToField Field where + toField = id +instance ToField a => ToField (Maybe a) where + toField Nothing = FieldString mempty NoEscape + toField (Just a) = toField a + +instance ToField Int8 where + toField = FieldInteger . into +instance ToField Int16 where + toField = FieldInteger . into +instance ToField Int32 where + toField = FieldInteger . into +instance ToField Int64 where + toField = FieldInteger . into +instance ToField Int where + toField = FieldInteger . into + +instance ToField Word8 where + toField = FieldInteger . into +instance ToField Word16 where + toField = FieldInteger . into +instance ToField Word32 where + toField = FieldInteger . into +instance ToField Word64 where + toField = FieldInteger . into +instance ToField Word where + toField = FieldInteger . into +instance ToField Word128 where + toField = FieldInteger . into +instance ToField Word256 where + toField = FieldInteger . into + +instance ToField Integer where + toField = FieldInteger +instance ToField Natural where + toField = FieldInteger . into + +instance ToField Double where + toField = FieldDouble + +instance ToField Char where + toField = string . String.singleton + +instance ToField (Offset a) where + toField = FieldInteger . into +instance ToField (CountOf a) where + toField = FieldInteger . into + +instance ToField [Char] where + toField = string . fromString +instance ToField String where + toField = string + +-- | helper function to create a `FieldInteger` +-- +integral :: Into Integer a => a -> Field +integral = FieldInteger . into + +float :: Double -> Field +float = FieldDouble + +-- | heler function to create a FieldString. +-- +-- This function will findout automatically if an escaping is needed. +-- if you wish to perform the escaping manually, do not used this function +-- +string :: String -> Field +string s = FieldString s encoding + where + encoding + | any g s = DoubleEscape + | any f s = Escape + | otherwise = NoEscape + f c = c == '\"' + g c = c `elem` ",\r\n" + +-- | CSV Row +-- +newtype Row = Row { unRow :: Array Field } + deriving (Eq, Show, Typeable, Semigroup, Monoid, Collection, NormalForm, Sequential, IndexedCollection) + +type instance Element Row = Field +instance IsList Row where + type Item Row = Field + toList = toList . unRow + fromList = Row . fromList + +class ToRow a where + toRow :: a -> Row +instance ToRow Row where + toRow = id +instance (ToField a, ToField b) => ToRow (a,b) where + toRow (a,b) = fromList [toField a, toField b] +instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) where + toRow (a,b,c) = fromList [toField a, toField b, toField c] +instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) where + toRow (a,b,c,d) = fromList [toField a, toField b, toField c, toField d] +instance (ToField a, ToField b, ToField c, ToField d, ToField e) => ToRow (a,b,c,d,e) where + toRow (a,b,c,d,e) = fromList [toField a, toField b, toField c, toField d, toField e] +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => ToRow (a,b,c,d,e,f) where + toRow (a,b,c,d,e,f) = fromList [toField a, toField b, toField c, toField d, toField e, toField f] + +-- | CSV Type +newtype CSV = CSV { unCSV :: Array Row } + deriving (Eq, Show, Typeable, Semigroup, Monoid, Collection, NormalForm, Sequential, IndexedCollection) + +type instance Element CSV = Row + +instance IsList CSV where + type Item CSV = Row + toList = toList . unCSV + fromList = CSV . fromList + +-- | serialise the CSV document into a UTF8 string +csvStringBuilder :: CSV -> String.Builder +csvStringBuilder = String.unsafeStringBuilder . csvBlockBuilder + +rowStringBuilder :: Row -> String.Builder +rowStringBuilder = String.unsafeStringBuilder . rowBlockBuilder + +fieldStringBuilder :: Field -> String.Builder +fieldStringBuilder = String.unsafeStringBuilder . fieldBlockBuilder + +-- | serialise the CSV document into a UTF8 encoded (Block Word8) +csvBlockBuilder :: CSV -> Block.Builder +csvBlockBuilder = mconcat . intersperse (Block.emitString "\r\n") . fmap rowBlockBuilder . toList . unCSV + +rowBlockBuilder :: Row -> Block.Builder +rowBlockBuilder = mconcat . intersperse (Block.emitUTF8Char ',') . fmap fieldBlockBuilder . toList . unRow + +fieldBlockBuilder :: Field -> Block.Builder +fieldBlockBuilder (FieldInteger i) = Block.emitString $ show i +fieldBlockBuilder (FieldDouble d) = Block.emitString $ show d +fieldBlockBuilder (FieldString s e) = case e of + NoEscape -> Block.emitString s + Escape -> Block.emitUTF8Char '"' <> Block.emitString s <> Block.emitUTF8Char '"' + DoubleEscape -> Block.emitUTF8Char '"' <> Block.emitString (replace "\"" "\"\"" s) <> Block.emitUTF8Char '"' + +rowC :: (ToRow row, Monad m) => Conduit row (Block Word8) m () +rowC = await >>= go + where + go Nothing = pure () + go (Just r) = + let bytes = runST (Block.run $ rowBlockBuilder (toRow r) <> Block.emitString "\r\n") + in yield bytes >> await >>= go diff --git a/Foundation/Hashing/FNV.hs b/Foundation/Hashing/FNV.hs --- a/Foundation/Hashing/FNV.hs +++ b/Foundation/Hashing/FNV.hs @@ -21,6 +21,7 @@ , FNV1a_64 ) where +import Basement.Block (Block(..)) import Basement.Compat.Base import qualified Basement.UArray as A import Basement.Types.OffsetSize @@ -119,8 +120,8 @@ ba :: A.UArray Word8 ba = A.unsafeRecast baA - goVec :: ByteArray# -> Offset Word8 -> FNV1_32 - goVec !ma !start = loop start initialState + goVec :: Block Word8 -> Offset Word8 -> FNV1_32 + goVec (Block !ma) !start = loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc @@ -144,8 +145,8 @@ ba :: A.UArray Word8 ba = A.unsafeRecast baA - goVec :: ByteArray# -> Offset Word8 -> FNV1a_32 - goVec !ma !start = loop start initialState + goVec :: Block Word8 -> Offset Word8 -> FNV1a_32 + goVec (Block !ma) !start = loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc @@ -169,8 +170,8 @@ ba :: A.UArray Word8 ba = A.unsafeRecast baA - goVec :: ByteArray# -> Offset Word8 -> FNV1_64 - goVec !ma !start = loop start initialState + goVec :: Block Word8 -> Offset Word8 -> FNV1_64 + goVec (Block !ma) !start = loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc @@ -194,8 +195,8 @@ ba :: A.UArray Word8 ba = A.unsafeRecast baA - goVec :: ByteArray# -> Offset Word8 -> FNV1a_64 - goVec !ma !start = loop start initialState + goVec :: Block Word8 -> Offset Word8 -> FNV1a_64 + goVec (Block !ma) !start = loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc diff --git a/Foundation/Hashing/SipHash.hs b/Foundation/Hashing/SipHash.hs --- a/Foundation/Hashing/SipHash.hs +++ b/Foundation/Hashing/SipHash.hs @@ -24,6 +24,7 @@ import Basement.Cast (cast) import Basement.IntegralConv import Foundation.Hashing.Hasher +import Basement.Block (Block(..)) import qualified Basement.UArray as A import Foundation.Array import Foundation.Numerical @@ -186,8 +187,8 @@ totalLen = A.length array8 array8 = A.unsafeRecast array - goVec :: ByteArray# -> Offset Word8 -> Sip - goVec ba start = loop8 initSt initIncr start totalLen + goVec :: Block Word8 -> Offset Word8 -> Sip + goVec (Block ba) start = loop8 initSt initIncr start totalLen where loop8 !st !incr _ 0 = Sip st incr (currentLen + totalLen) loop8 !st SipIncremental0 !ofs !l = case l - 8 of diff --git a/Foundation/Network/IPv6.hs b/Foundation/Network/IPv6.hs --- a/Foundation/Network/IPv6.hs +++ b/Foundation/Network/IPv6.hs @@ -25,7 +25,6 @@ import qualified Text.Printf as Base import Data.Char (isHexDigit, isDigit) import Numeric (readHex) -import Control.Monad (when) import Foundation.Class.Storable import Foundation.Hashing.Hashable diff --git a/Foundation/Timing/Main.hs b/Foundation/Timing/Main.hs --- a/Foundation/Timing/Main.hs +++ b/Foundation/Timing/Main.hs @@ -14,7 +14,6 @@ import Basement.Imports import Foundation.IO.Terminal import Foundation.Collection -import Control.Monad (when) data MainConfig = MainConfig { mainHelp :: Bool diff --git a/Foundation/UUID.hs b/Foundation/UUID.hs --- a/Foundation/UUID.hs +++ b/Foundation/UUID.hs @@ -9,7 +9,6 @@ , uuidParser ) where -import Control.Monad (unless) import Data.Maybe (fromMaybe) import Basement.Compat.Base 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 Gauge hiding (bgroup, bench) -import qualified Gauge as C +import Gauge.Main hiding (bgroup, bench) +import qualified Gauge.Main as C import Foundation fbench = bench "foundation" diff --git a/benchs/BenchUtil/RefData.hs b/benchs/BenchUtil/RefData.hs --- a/benchs/BenchUtil/RefData.hs +++ b/benchs/BenchUtil/RefData.hs @@ -7,6 +7,9 @@ , rdFoundationZh , rdFoundationJap , rdFoundationHun + , rdFoundationLower + , rdFoundationUpper + , rdSpecialCasing -- byte array , rdBytes20 , rdBytes200 @@ -26,6 +29,12 @@ rdFoundationEn :: [Char] rdFoundationEn = "Set in the year 0 F.E. (\"Foundation Era\"), The Psychohistorians opens on Trantor, the capital of the 12,000-year-old Galactic Empire. Though the empire appears stable and powerful, it is slowly decaying in ways that parallel the decline of the Western Roman Empire. Hari Seldon, a mathematician and psychologist, has developed psychohistory, a new field of science and psychology that equates all possibilities in large societies to mathematics, allowing for the prediction of future events." +rdFoundationLower :: [Char] +rdFoundationLower = "set in the year 0 f.e. (\"foundation era\"), the psychohistorians opens on trantor, the capital of the 12,000-year-old galactic empire. though the empire appears stable and powerful, it is slowly decaying in ways that parallel the decline of the western roman empire. hari seldon, a mathematician and psychologist, has developed psychohistory, a new field of science and psychology that equates all possibilities in large societies to mathematics, allowing for the prediction of future events." + +rdFoundationUpper :: [Char] +rdFoundationUpper = "SET IN THE YEAR 0 F.E. (\"FOUNDATION ERA\"), THE PSYCHOHISTORIANS OPENS ON TRANTOR, THE CAPITAL OF THE 12,000-YEAR-OLD GALACTIC EMPIRE. THOUGH THE EMPIRE APPEARS STABLE AND POWERFUL, IT IS SLOWLY DECAYING IN WAYS THAT PARALLEL THE DECLINE OF THE WESTERN ROMAN EMPIRE. HARI SELDON, A MATHEMATICIAN AND PSYCHOLOGIST, HAS DEVELOPED PSYCHOHISTORY, A NEW FIELD OF SCIENCE AND PSYCHOLOGY THAT EQUATES ALL POSSIBILITIES IN LARGE SOCIETIES TO MATHEMATICS, ALLOWING FOR THE PREDICTION OF FUTURE EVENTS." + rdFoundationZh :: [Char] rdFoundationZh = "故事發生在〈心理史學家〉五十年後，端點星面臨首度的「謝頓危機」（Seldon Crisis）銀河帝國邊緣的星群紛紛獨立起來，端點星處於四個王國之間，備受威脅。此時，謝頓早前錄下影像突然播放，告知他的後人端點星「銀河百科全書第一號基地」的真正目的──在千年後建立一個新的銀河帝國。同時，在這一千年間，基地會遇到各種不同的危機，令基地可以急速成長。端點星市長塞佛·哈定（Salvor Hardin）趁機發動政變，從心神未定的百科全書理事會手中奪權，以他靈活的手腕帶領端點星走出危機。" @@ -34,6 +43,9 @@ rdFoundationJap :: [Char] rdFoundationJap = "数学者ハリ・セルダンは、膨大な集団の行動を予測する心理歴史学を作りあげ発展させることで、銀河帝国が近いうちに崩壊することを予言する[1]。セルダンは、帝国崩壊後に3万年続くはずの暗黒時代を、あらゆる知識を保存することで千年に縮めようとし、知識の集大成となる銀河百科事典 (Encyclopedia Galactica) を編纂するグループ「ファウンデーション」をつくったが、帝国崩壊を公言し平和を乱したという罪で裁判にかけられ、グループは銀河系辺縁部にある資源の乏しい無人惑星ターミナスへ追放されることになった。しかし、この追放劇すらもセルダンの計画に予定されていた事柄であった。病で死期をさとっていたセルダンは、己の仕事が終わったことを確信する。" + +rdSpecialCasing :: [Char] +rdSpecialCasing = "fflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflffl" rdBytes20 ::[Word8] rdBytes20 = take 20 $ cycle [1..255] diff --git a/benchs/Fake/Text.hs b/benchs/Fake/Text.hs --- a/benchs/Fake/Text.hs +++ b/benchs/Fake/Text.hs @@ -11,6 +11,8 @@ , decimal , double , decodeUtf8 + , toLower + , toUpper ) where import Prelude (undefined, Either(..), Char) @@ -27,6 +29,8 @@ reverse = undefined any = undefined decodeUtf8 = undefined +toLower = undefined +toUpper = undefined decimal :: Text -> Either a (b, c) decimal = undefined diff --git a/benchs/Main.hs b/benchs/Main.hs --- a/benchs/Main.hs +++ b/benchs/Main.hs @@ -43,6 +43,8 @@ , benchFilter , benchRead , benchFromUTF8Bytes + , benchUpper + , benchLower ] where diffTextString :: (String -> a) @@ -132,6 +134,14 @@ benchFilter = bgroup "Filter" $ fmap (\(n, dat) -> bgroup n $ diffTextString (filter (> 'b')) (Just $ filter (> 'b')) (Text.filter (> 'b')) dat) allDat + + benchUpper = bgroup "Upper" $ + fmap (\(n, dat) -> bgroup n $ diffTextString upper Nothing Text.toUpper dat) + (("special casing", rdSpecialCasing) : ("ascii already upper", rdFoundationUpper) : allDat) + + benchLower = bgroup "Lower" $ + fmap (\(n, dat) -> bgroup n $ diffTextString lower Nothing Text.toLower dat) + (("special casing", rdSpecialCasing) : ("ascii already lower", rdFoundationLower) : allDat) benchRead = bgroup "Read" [ bgroup "Integer" diff --git a/foundation.cabal b/foundation.cabal --- a/foundation.cabal +++ b/foundation.cabal @@ -1,5 +1,5 @@ name: foundation -version: 0.0.19 +version: 0.0.20 synopsis: Alternative prelude with batteries and no dependencies description: A custom prelude with no dependencies apart from base. @@ -59,10 +59,15 @@ manual: True flag doctest - description: Add extra friendly boundary check for unsafe array operations + description: Build doctest on demand only default: False manual: True +flag linktest + description: Run linking test + default: False + manual: True + library exposed-modules: Foundation Foundation.Numerical @@ -74,6 +79,7 @@ Foundation.Conduit Foundation.Conduit.Textual Foundation.Exception + Foundation.Format.CSV Foundation.String Foundation.String.Read Foundation.String.Builder @@ -110,7 +116,7 @@ Foundation.UUID Foundation.System.Entropy Foundation.System.Bindings - other-modules: + other-modules: Foundation.Tuple Foundation.Hashing.FNV Foundation.Hashing.SipHash @@ -191,7 +197,7 @@ BangPatterns DeriveDataTypeable build-depends: base >= 4.7 && < 5 - , basement == 0.0.6 + , basement == 0.0.7 , ghc-prim -- FIXME add suport for armel mipsel -- CPP-options: -DARCH_IS_LITTLE_ENDIAN @@ -228,6 +234,8 @@ Test.Data.List Test.Foundation.Network.IPv4 Test.Foundation.Network.IPv6 + Test.Foundation.Format + Test.Foundation.Format.CSV default-extensions: NoImplicitPrelude RebindableSyntax OverloadedStrings @@ -239,6 +247,21 @@ if impl(ghc >= 8.0) ghc-options: -Wno-redundant-constraints +test-suite foundation-link + type: exitcode-stdio-1.0 + hs-source-dirs: tests + default-language: Haskell2010 + main-is: Scripts/Link.hs + default-extensions: NoImplicitPrelude + RebindableSyntax + if flag(linktest) + build-depends: base + , foundation + , template-haskell + buildable: True + else + buildable: False + test-suite doctest type: exitcode-stdio-1.0 hs-source-dirs: tests @@ -273,7 +296,7 @@ if flag(minimal-deps) || impl(ghc < 7.10) buildable: False else - build-depends: base >= 4, gauge >= 0.2.0, 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/Checks.hs b/tests/Checks.hs --- a/tests/Checks.hs +++ b/tests/Checks.hs @@ -28,6 +28,7 @@ import Test.Foundation.Network.IPv6 import Test.Foundation.String.Base64 import Test.Checks.Property.Collection +import Test.Foundation.Format import qualified Test.Foundation.Bits as Bits #if MIN_VERSION_base(4,9,0) @@ -197,11 +198,11 @@ , testNetworkIPv6 , testBase64Refs , testHexadecimal - , testTime , testUUID , testRandom , testConduit #if MIN_VERSION_base(4,9,0) , testBlockN #endif + , testFormat ] diff --git a/tests/Scripts/Link.hs b/tests/Scripts/Link.hs new file mode 100644 --- /dev/null +++ b/tests/Scripts/Link.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module is to test issue +-- https://github.com/haskell-foundation/foundation/issues/326 +-- +-- this test has been originaly proposed by https://github.com/RyanGlScott +-- in comment of the issue 326: +-- https://github.com/haskell-foundation/foundation/issues/326#issuecomment-309219955 + +module Main (main) where + +import Foundation as F +import Language.Haskell.TH + +main :: IO () +main = $(do runIO $ F.putStrLn (F.fromString "Hello") + [| return () |]) diff --git a/tests/Test/Foundation/Format.hs b/tests/Test/Foundation/Format.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Foundation/Format.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test.Foundation.Format + ( testFormat + ) where + +import Foundation +import Foundation.Check +import Test.Foundation.Format.CSV + + +testFormat :: Test +testFormat = Group "Format" + [ testFormatCSV + ] diff --git a/tests/Test/Foundation/Format/CSV.hs b/tests/Test/Foundation/Format/CSV.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Foundation/Format/CSV.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Foundation.Format.CSV + ( testFormatCSV + ) where + +import Foundation +import Foundation.Format.CSV +import Foundation.Check +import Foundation.String.Builder (toString) + +testFormatCSV :: Test +testFormatCSV = Group "CSV" + [ Group "field unit tests" $ testFieldEncoding <$> fieldUnitTests + , Group "row unit tests" $ testRowEncoding <$> rowUnitTests + ] + + where + testFieldEncoding (f,r) = Property (show f) $ + let str = toString (fieldStringBuilder f) + in r === str + testRowEncoding (row,result) = Property (show row) $ + let str = toString (rowStringBuilder row) + in result === str + +fieldUnitTests :: [(Field, String)] +fieldUnitTests = + [ (FieldInteger 42, "42") + , (FieldDouble 1, "1.0") + , (FieldDouble 0.000001, "1.0e-6") + , (FieldString "String" NoEscape, "String") + , (string "String", "String") + , (string "with comma,string", "\"with comma,string\"") + , (FieldString "multiline\nstring" Escape, "\"multiline\nstring\"") + , (FieldString "piece of 12\" by 23\"" DoubleEscape, "\"piece of 12\"\" by 23\"\"\"") + , (string "supported sizes are: 12\", 13\" and 14\"", "\"supported sizes are: 12\"\", 13\"\" and 14\"\"\"") + ] + +rowUnitTests :: [(Row, String)] +rowUnitTests = + [ (fromList [toField (42 :: Int), toField ("some string" :: String)], "42,some string") + , (toRow (42 :: Int, "some string" :: String), "42,some string") + , ( toRow ( 42 :: Int + , "some string" :: String + , "supported sizes are: 12\", 13\" and 14\"" :: String + ) + , "42,some string,\"supported sizes are: 12\"\", 13\"\" and 14\"\"\"" + ) + , ( toRow ( 42 :: Int + , "some string" :: String + , "supported sizes are: 12\", 13\" and 14\"" :: String + , Just 0.000001 :: Maybe Double + ) + , "42,some string,\"supported sizes are: 12\"\", 13\"\" and 14\"\"\",1.0e-6" + ) + , ( toRow ( 42 :: Int + , "some string" :: String + , "supported sizes are: 12\", 13\" and 14\"" :: String + , Just 0.000001 :: Maybe Double + , Nothing :: Maybe Char + ) + , "42,some string,\"supported sizes are: 12\"\", 13\"\" and 14\"\"\",1.0e-6," + ) + ] diff --git a/tests/Test/Foundation/Misc.hs b/tests/Test/Foundation/Misc.hs --- a/tests/Test/Foundation/Misc.hs +++ b/tests/Test/Foundation/Misc.hs @@ -1,8 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} module Test.Foundation.Misc ( testHexadecimal - , testTime , testUUID ) where @@ -33,16 +31,6 @@ testHexadecimal = Group "hexadecimal" [ Property "UArray(W8)" $ \l -> toList (toHexadecimal (fromListP (Proxy :: Proxy (UArray Word8)) l)) == hex l - ] - -testTime = Group "Time" - [ Property "foundation_time_clock_gettime links properly" $ - $(let s :: String - s = fromString "Hello" - - b :: Bool - b = s == s - in [| b |]) ] testUUID = Group "UUID" diff --git a/tests/Test/Foundation/String.hs b/tests/Test/Foundation/String.hs --- a/tests/Test/Foundation/String.hs +++ b/tests/Test/Foundation/String.hs @@ -68,7 +68,7 @@ , CheckPlan "B should not capitalize" $ validate "B" $ upper "B" == "B" , CheckPlan "é should capitalize to É" $ validate "é" $ upper "é" == "É" , CheckPlan "ß should capitalize to SS" $ validate "ß" $ upper "ß" == "SS" - , CheckPlan "ffl should capitalize to FFL" $ validate "ffl" $ upper "ffl" == "FFL" + , CheckPlan "ffl should capitalize to FFL" $ validate "ffl" $ upper "fflfflfflfflfflfflfflfflfflffl" == "FFLFFLFFLFFLFFLFFLFFLFFLFFLFFL" , CheckPlan "0a should capitalize to 0A" $ validate "0a" $ upper "\0a" == "\0A" , CheckPlan "0a should capitalize to 0A" $ validate "0a" $ upper "a\0a" == "A\0A" , CheckPlan "0a should capitalize to 0A" $ validate "0a" $ upper "\0\0" == "\0\0"