diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,286 +0,0 @@ -## 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 -* Improve concat for Block andd UArray -* Add unicode case mapping -* Re-add compatibility with ghc 7.8 - -## 0.0.18 - -* Add missing lowlevel Block functionality -* Cleanup UArray to use more functions from Block -* Push Xoroshiro down to basement -* Add instances for foundation's numerical classes for C types -* Update benchmarks to gauge 0.2.0 -* Add documentation to some block & uarray functions - -## 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 - -## 0.0.14 - -Types: - -* Add bounded Natural (Zn & Zn64) -* Add Word128 and Word256 - -Class: - -* Add From/Into type class - -Collection: - -* Add breakEnd, spanEnd, revFindIndex -* Improve arrays sorting -* Add arrays fromListN implementation -* Add arrays convertion primitive - -BlockN: - -* Cleanup API -* Implement unsnoc - -Misc: - -* Improve random generation with XorShift -* Improve ghc 8.2 support (warning removals) -* Remove dependency on QuickCheck -* Split lowlevel modules into basement package -* Fix compilation with musl -* Improve native array safety when using through pointer - -File: - -* remove foldText - -## 0.0.13 - -Block: -* Optimise fold - -UArray: -* Re-organise type to be more modular for later change -* Remove the pinned array explicit status in favor of asking - the runtime system directly on demand. -* Optimise fold operations -* Optimise all&any -* Optimise isPrefixOf -* Optimise isSuffixOf -* Optimise finding byte -* Add an optimise function to break on line (CRLF & LF) as part of a stream - -String: -* Optimise length -* Optimise all&any -* Optimise foldr -* Remove many unboxed tuples (next, prev, ..) in favor of a strict unpack - constructor -* Optimise lines using array breakLine - -Collection: -* add stripPrefix & stripSuffix - -Tests: -* Improve performance - -Misc: -* Cleanup Offset/Size types with the C boundary -* Faster Offset/Size convertions -* Add Base64 support -* Add LE/BE instance for NormalForm -* Add UUID generation and parsing - -## 0.0.12 - -* Fix build windows building & time subsystem -* Add BlockN: Typed-fixed length block of memory -* Add Base64 -* Add 'or' and 'and' - -## 0.0.11 - -* Add Hlint support (configuration file), and default travis job -* Property report error through with the ASCII, UTF16, UTF32 string decoders -* Fix issue with OSX < Sierra -* Improve Parser and fix backtracking issue -* Strictify UArray to contains a strict ByteArray# -* Improve any & all for most collection types -* Improve minimum & maximum for most collection types -* Add foldl1 & foldr1 -* Add takeWhile & dropWhile -* Remove foldl -* Add basic String builder -* Add String replace function -* Add conduit sourceList -* Improve performance of String uncons, unsnoc, filter and fromBytes UTF8 (validate) -* Improve UArray filter -* Fix compilation issue on windows with `clock_gettime` which is not available though all possible compilation mode - -## 0.0.10 - -* Cleanup collection APIs that take a lone Int (length, take, drop, splitAt, ..) to take a CountOf -* Rename Size to CountOf -* Add basic time functions -* Add os dependent timing capability -* Add simple pattern matching for test names with checks. -* add '--list-tests' for checks -* Optimise Eq and Ord for blocks and uarray - -## 0.0.9 - -* Introduce Block & MutableBlock which represent a chunk of memory without slices - and are faster/leaner in many cases. -* Cleanup String code and some primitives boundaries -* Fix storable alignment tests -* Add These data type (either a, b or both) -* Implement checks command line -* Improve checks terminal output -* drop support for GHC 7.4 and GHC 7.6 -* Improve performance of copy out of block and uarray - -## 0.0.8 - -* Add MonadReader and MonadState -* Improve performance of numerical read parsers (integral, double) -* Improve precision of double read parser -* Add Textual conduit combinator (fromBytes, toBytes, lines) -* Add DList -* Fix building on latest Win32, RHEL 5.8 -* Add NormalForm -* Export some functions in Internal module to manipulate unboxed mutable array - -## 0.0.7 - -* Improve Checks: random seed, new properties and improved printing -* Add ability to parse Natural, Integer, and Double from String -* Temporarily remove compilation of experimental network resolution introduced in 0.0.5 for windows building. -* Cleanup Offset and Size fixing some bug in String module - -## 0.0.6 - -* Fix build on Centos 6.x / older linux distribution -* Improve test checks generators - -## 0.0.5 - -* Generalize monadic map (mapM, mapM\_) -* HostName type -* Network address / name resolution -* Fix compilation on FreeBSD & OpenBSD -* Initial re-implementation for property tests and tests orchestration -* Fix bug in splitElem, and breakElem -* Improve splitOn to return empty elements -* Fix API bug for snoc and cons in Chunked UArray -* Add UUID -* Check API -* Fix compilation on !x86 - -## 0.0.4 - -* Add Conduit for all your streaming needs -* Expose Sequential from Foundation -* Export internal withPtr for optimisation -* Export `ifThenElse` -* Use the proper `String` type for error instead of `[Char]` -* Add `any` and `all` to `Collection` -* Add defaulting to Integer and Double for numerical types -* Add negation for Double and Float (and their associated C types) -* Add/Export system bindings (Posix file/memory handling, Linux Inotify) -* Add Big Endian (BE) / Little Endian (LE) wrapping types -* Add a way to transform an UArray into Hexadecimal/Base16 -* Add IPv4 and IPv6 types - -## 0.0.3 - -Monad: - -* Add MonadCatch and MonadThrow classes -* Add Transformer base class (MonadTrans) -* Add IdentityT, StateT, ReaderT - -Build: - -* Fix build on !x86 - -## 0.0.2 - -Classes: - -* Add `Bifunctor` -* Implement Better storable type class (#111) -* Expose Nthable for GHC >= 7.10 (product type getter) -* Split basic function from `Sequential` to `Collection` -* show return a Foundation `String` now instead of `[Char]` - -Numerical: -* Overhaul of numerical classes (`Integral`, `Rational`, `Divisible`, ..) -* add IntegralRounding (i.e. rounding from floating types) -* Expose IEEE manipulation stuff -* Expose all trigonometry functions in `Foundation.Math.Trigonometry` -* Export `Natural` (Unsigned `Integer`) - -Collection: -* Add partition -* Add isPrefixOf and isSuffixOf -* Add ArrayBuilder machinery -* Add `String` parser -* Add minimum and maximum to Collection. -* Export Foldable and Collection in Foundation -* add head,last,tail,init - -Types: -* Basic `ArrayUArray` support (Array of unboxed Array) -* Add instance for `Float` and `Double` for numerical -* Boxed array: add native slicing in the type -* add `NonEmpty` type -* Add some Data declaration for based type - -Hashing: -* Hashing: add FNV, SipHash hash functions family -* Hashable: add support to hash types - -Random support: -* Add support for system entropy -* Add pseudo random generation capability using a ChaCha core. - -## 0.0.1 - -* Initial version diff --git a/Foundation/Format/CSV.hs b/Foundation/Format/CSV.hs --- a/Foundation/Format/CSV.hs +++ b/Foundation/Format/CSV.hs @@ -17,216 +17,38 @@ CSV -- ** Builder - -- ** String Bulider + -- *** String Bulider , csvStringBuilder , rowStringBuilder , fieldStringBuilder - -- ** Block Builder + -- *** Block Builder , csvBlockBuilder , rowBlockBuilder , fieldBlockBuilder -- ** Conduit , rowC + + -- ** Parser + -- *** String Bulider + , file + , record + , record_ + , field + -- ** Conduit + , recordC -- * Row , Row - , ToRow(..) + , Record(..) -- * Field , Field(..) , Escaping(..) - , ToField(..) + , IsField(..) -- ** 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 +import Foundation.Format.CSV.Types +import Foundation.Format.CSV.Builder +import Foundation.Format.CSV.Parser diff --git a/Foundation/Format/CSV/Builder.hs b/Foundation/Format/CSV/Builder.hs new file mode 100644 --- /dev/null +++ b/Foundation/Format/CSV/Builder.hs @@ -0,0 +1,71 @@ +-- | +-- Module : Foundation.Format.CSV.Builder +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- +-- Provies the support for Comma Separated Value + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Foundation.Format.CSV.Builder + ( -- * String Bulider + csvStringBuilder + , rowStringBuilder + , fieldStringBuilder + -- * Block Builder + , csvBlockBuilder + , rowBlockBuilder + , fieldBlockBuilder + -- * Conduit + , rowC + ) where + +import Basement.Imports +import Basement.String (replace) +import Foundation.Collection.Sequential (Sequential(intersperse)) +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) + +import Foundation.Format.CSV.Types + +-- | 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 :: (Record 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/Format/CSV/Parser.hs b/Foundation/Format/CSV/Parser.hs new file mode 100644 --- /dev/null +++ b/Foundation/Format/CSV/Parser.hs @@ -0,0 +1,131 @@ +-- | CSV parser as specified in RFC4180 +-- + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Foundation.Format.CSV.Parser + ( file + , recordC + , record + , record_ + , field + ) where + +import Basement.Imports hiding (throw) +import Foundation.Format.CSV.Types +import Basement.String (snoc) +import Foundation.Parser +import Foundation.Monad +import Foundation.Collection (Collection (elem)) +import Foundation.Conduit +import Control.Monad (void) +import Data.Typeable (typeRep) +import Data.Proxy (Proxy(..)) + +recordC :: (Monad m, MonadThrow m) => Conduit String Row m () +recordC = awaitForever $ recordC' . parse (record <* optional (elements crlf)) + where + recordC' (ParseFailed err) = throw err + recordC' (ParseOk rest v) = leftover rest *> yield v + recordC' (ParseMore more) = do + mm <- await + case mm of + Nothing -> throw (NotEnoughParseOnly :: ParseError String) + Just b -> recordC' (more b) + +record_ :: forall row . (Typeable row, Record row) => Parser String row +record_ = do + rs <- record + case fromRow rs of + Left err -> reportError $ Expected (show $ typeRep (Proxy @row)) err + Right v -> pure v + +file :: Parser String CSV +file = do + mh <- optional $ header <* elements crlf + x <- record + xs <- some $ elements crlf *> record + void $ optional $ elements crlf + pure $ fromList $ case mh of + Nothing -> x : xs + Just h -> h : x : xs + +header :: Parser String Row +header = do + x <- name + xs <- some $ element comma *> name + pure $ fromList $ x : xs + +record :: Parser String Row +record = do + x <- field + xs <- some $ element comma *> field + pure $ fromList $ x : xs + +name :: Parser String Field +name = field +{-# INLINE name #-} + +field :: Parser String Field +field = escaped <|> nonEscaped + +escaped :: Parser String Field +escaped = element dquote *> escaped' + where + escaped' = do + x <- takeWhile (dquote /=) + element dquote + p <- peek + if p == (Just dquote) + then skip 1 >> descaped' (snoc x dquote) + else pure (FieldString x Escape) + descaped' acc = do + x <- takeWhile (dquote /=) + element dquote + p <- peek + if p == (Just dquote) + then skip 1 >> descaped' (acc <> snoc x dquote) + else pure (FieldString (acc <> x) DoubleEscape) + +nonEscaped :: Parser String Field +nonEscaped = flip FieldString NoEscape <$> takeWhile (not . flip elem specials) +{-# INLINE nonEscaped #-} + +comma :: Char +comma = ',' +{-# INLINE comma #-} + +cr :: Char +cr = '\r' +{-# INLINE cr #-} + +dquote :: Char +dquote = '"' +{-# INLINE dquote #-} + +lf :: Char +lf = '\n' +{-# INLINE lf #-} + +crlf :: String +crlf = fromList [cr, lf] +{-# NOINLINE crlf #-} + +{- +textdataQuoted :: String +textdataQuoted = textdata <> specials +{-# NOINLINE textdataQuoted #-} +-} + +specials :: String +specials = ",\r\n" +{-# INLINE specials #-} + +{- +textdata :: String +textdata = fromList $ [' '..'!'] <> ['#'..'+'] <> ['-'..'~'] +{-# NOINLINE textdata #-} +-} diff --git a/Foundation/Format/CSV/Types.hs b/Foundation/Format/CSV/Types.hs new file mode 100644 --- /dev/null +++ b/Foundation/Format/CSV/Types.hs @@ -0,0 +1,265 @@ +-- | +-- Module : Foundation.Format.CSV.Types +-- License : BSD-style +-- Maintainer : Foundation +-- Stability : experimental +-- Portability : portable +-- + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Foundation.Format.CSV.Types + (-- * CSV + CSV + , unCSV + + -- * Row + , Row + , unRow + , Record(..) + -- * Field + , Field(..) + , Escaping(..) + , IsField(..) + -- ** helpers + , integral + , float + , string + ) where + +import Basement.Imports +import Basement.BoxedArray (Array, length, unsafeIndex) +import Basement.NormalForm (NormalForm(..)) +import Basement.From (Into, into) +import Basement.String (String, any, elem, null, uncons) +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) +import Foundation.Collection.Indexed (IndexedCollection) +import Foundation.Check.Arbitrary (Arbitrary(..), frequency) +import Foundation.String.Read (readDouble, readInteger) + +-- | 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 IsField a where + toField :: a -> Field + fromField :: Field -> Either String a +instance IsField Field where + toField = id + fromField = pure +instance IsField a => IsField (Maybe a) where + toField Nothing = FieldString mempty NoEscape + toField (Just a) = toField a + fromField stuff@(FieldString p NoEscape) + | null p = pure Nothing + | otherwise = Just <$> fromField stuff + fromField stuff = Just <$> fromField stuff + +fromIntegralField :: Integral b => Field -> Either String b +fromIntegralField (FieldString str NoEscape) = case readInteger str of + Nothing -> Left "Invalid integral field" + Just v -> pure $ fromInteger v +fromIntegralField (FieldInteger v) = pure (fromInteger v) +fromIntegralField _ = Left "Expected integral value" + +fromDoubleField :: Field -> Either String Double +fromDoubleField (FieldString str NoEscape) = case readDouble str of + Nothing -> Left "Invalid double field" + Just v -> pure v +fromDoubleField (FieldDouble v) = pure v +fromDoubleField _ = Left "Expected double value" + +instance IsField Bool where + toField = toField . show + fromField (FieldString "True" NoEscape) = pure True + fromField (FieldString "False" NoEscape) = pure False + fromField _ = Left "not a boolean value" +instance IsField Int8 where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField Int16 where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField Int32 where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField Int64 where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField Int where + toField = FieldInteger . into + fromField = fromIntegralField + +instance IsField Word8 where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField Word16 where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField Word32 where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField Word64 where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField Word where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField Word128 where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField Word256 where + toField = FieldInteger . into + fromField = fromIntegralField + +instance IsField Integer where + toField = FieldInteger + fromField = fromIntegralField +instance IsField Natural where + toField = FieldInteger . into + fromField = fromIntegralField + +instance IsField Double where + toField = FieldDouble + fromField = fromDoubleField + +instance IsField Char where + toField = string . String.singleton + fromField (FieldString str _) = case uncons str of + Just (c, str') | null str' -> pure c + | otherwise -> Left "Expected a char, but received a String" + Nothing -> Left "Expected a char" + fromField _ = Left "Expected a char" + +instance IsField (Offset a) where + toField = FieldInteger . into + fromField = fromIntegralField +instance IsField (CountOf a) where + toField = FieldInteger . into + fromField = fromIntegralField + +instance IsField [Char] where + toField = string . fromString + fromField (FieldString str _) = pure $ toList str + fromField _ = Left "Expected a Lazy String" +instance IsField String where + toField = string + fromField (FieldString str _) = pure str + fromField _ = Left "Expected a UTF8 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 + g c = c == '\"' + f 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 Record a where + toRow :: a -> Row + fromRow :: Row -> Either String a +instance Record Row where + toRow = id + fromRow = pure +instance (IsField a, IsField b) => Record (a,b) where + toRow (a,b) = fromList [toField a, toField b] + fromRow (Row row) + | length row == 2 = (,) <$> fromField (row `unsafeIndex` 0) <*> fromField (row `unsafeIndex` 1) + | otherwise = Left (show row) +instance (IsField a, IsField b, IsField c) => Record (a,b,c) where + toRow (a,b,c) = fromList [toField a, toField b, toField c] + fromRow (Row row) + | length row == 3 = (,,) <$> fromField (row `unsafeIndex` 0) + <*> fromField (row `unsafeIndex` 1) + <*> fromField (row `unsafeIndex` 2) + | otherwise = Left (show row) +instance (IsField a, IsField b, IsField c, IsField d) => Record (a,b,c,d) where + toRow (a,b,c,d) = fromList [toField a, toField b, toField c, toField d] + fromRow (Row row) + | length row == 4 = (,,,) <$> fromField (row `unsafeIndex` 0) + <*> fromField (row `unsafeIndex` 1) + <*> fromField (row `unsafeIndex` 2) + <*> fromField (row `unsafeIndex` 3) + | otherwise = Left (show row) +instance (IsField a, IsField b, IsField c, IsField d, IsField e) => Record (a,b,c,d,e) where + toRow (a,b,c,d,e) = fromList [toField a, toField b, toField c, toField d, toField e] + fromRow (Row row) + | length row == 5 = (,,,,) <$> fromField (row `unsafeIndex` 0) + <*> fromField (row `unsafeIndex` 1) + <*> fromField (row `unsafeIndex` 2) + <*> fromField (row `unsafeIndex` 3) + <*> fromField (row `unsafeIndex` 4) + | otherwise = Left (show row) +instance (IsField a, IsField b, IsField c, IsField d, IsField e, IsField f) => Record (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] + fromRow (Row row) + | length row == 6 = (,,,,,) <$> fromField (row `unsafeIndex` 0) + <*> fromField (row `unsafeIndex` 1) + <*> fromField (row `unsafeIndex` 2) + <*> fromField (row `unsafeIndex` 3) + <*> fromField (row `unsafeIndex` 4) + <*> fromField (row `unsafeIndex` 5) + | otherwise = Left (show row) + +-- | 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 diff --git a/Foundation/Hashing/FNV.hs b/Foundation/Hashing/FNV.hs --- a/Foundation/Hashing/FNV.hs +++ b/Foundation/Hashing/FNV.hs @@ -30,7 +30,6 @@ import Foundation.Numerical import Foundation.Hashing.Hasher import Data.Bits -import GHC.Prim import GHC.ST -- | FNV1(a) hash (32 bit variants) diff --git a/Foundation/Hashing/SipHash.hs b/Foundation/Hashing/SipHash.hs --- a/Foundation/Hashing/SipHash.hs +++ b/Foundation/Hashing/SipHash.hs @@ -31,7 +31,6 @@ import Foundation.Bits import qualified Prelude import GHC.ST -import GHC.Prim -- | SigHash Key data SipKey = SipKey {-# UNPACK #-} !Word64 diff --git a/Foundation/Monad/Base.hs b/Foundation/Monad/Base.hs --- a/Foundation/Monad/Base.hs +++ b/Foundation/Monad/Base.hs @@ -7,6 +7,7 @@ , MonadThrow(..) , MonadCatch(..) , MonadTrans(..) + , MonadFix(..) , IdentityT ) where @@ -16,3 +17,4 @@ import Foundation.Monad.Exception import Foundation.Monad.Transformer import Foundation.Monad.Identity +import Control.Monad.Fix (MonadFix(..)) diff --git a/Foundation/Monad/Except.hs b/Foundation/Monad/Except.hs --- a/Foundation/Monad/Except.hs +++ b/Foundation/Monad/Except.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE OverloadedStrings #-} module Foundation.Monad.Except ( ExceptT(..) ) where @@ -38,6 +39,13 @@ Left e -> return (Left e) Right x -> runExceptT (k x) fail = ExceptT . fail + +instance (AMPMonad m, MonadFix m) => MonadFix (ExceptT e m) where + mfix f = ExceptT (mfix (runExceptT . f . fromEither)) + where + fromEither (Right x) = x + fromEither (Left _) = error "mfix (ExceptT): inner computation returned Left value" + {-# INLINE mfix #-} instance MonadReader m => MonadReader (ExceptT e m) where type ReaderContext (ExceptT e m) = ReaderContext m diff --git a/Foundation/Monad/Reader.hs b/Foundation/Monad/Reader.hs --- a/Foundation/Monad/Reader.hs +++ b/Foundation/Monad/Reader.hs @@ -40,6 +40,10 @@ ma >>= mab = ReaderT $ \r -> runReaderT ma r >>= \a -> runReaderT (mab a) r {-# INLINE (>>=) #-} +instance (AMPMonad m, MonadFix m) => MonadFix (ReaderT s m) where + mfix f = ReaderT $ \r -> mfix $ \a -> runReaderT (f a) r + {-# INLINE mfix #-} + instance MonadTrans (ReaderT r) where lift f = ReaderT $ const f {-# INLINE lift #-} diff --git a/Foundation/Monad/State.hs b/Foundation/Monad/State.hs --- a/Foundation/Monad/State.hs +++ b/Foundation/Monad/State.hs @@ -47,6 +47,10 @@ ma >>= mab = StateT $ runStateT ma >=> (\(a, s2) -> runStateT (mab a) s2) {-# INLINE (>>=) #-} +instance (Functor m, MonadFix m) => MonadFix (StateT s m) where + mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s + {-# INLINE mfix #-} + instance MonadTrans (StateT s) where lift f = StateT $ \s -> f >>= return . (,s) {-# INLINE lift #-} diff --git a/Foundation/Monad/Transformer.hs b/Foundation/Monad/Transformer.hs --- a/Foundation/Monad/Transformer.hs +++ b/Foundation/Monad/Transformer.hs @@ -3,7 +3,6 @@ ( MonadTrans(..) ) where -import Basement.Compat.Base import Basement.Compat.AMP -- | Basic Transformer class diff --git a/Foundation/Network/IPv4.hs b/Foundation/Network/IPv4.hs --- a/Foundation/Network/IPv4.hs +++ b/Foundation/Network/IPv4.hs @@ -29,7 +29,7 @@ import Foundation.String (String) import Foundation.Primitive import Foundation.Bits -import Foundation.Parser +import Foundation.Parser hiding (peek) import Foundation.Collection (Sequential, Element, elem) -- | IPv4 data type diff --git a/Foundation/Parser.hs b/Foundation/Parser.hs --- a/Foundation/Parser.hs +++ b/Foundation/Parser.hs @@ -23,6 +23,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} module Foundation.Parser ( Parser @@ -38,7 +39,8 @@ ParserSource(..) , -- * combinator - element + peek + , element , anyElement , elements , string @@ -85,9 +87,9 @@ | Satisfy (Maybe String) -- ^ the @satisfy@ or @satisfy_@ function failed, deriving (Typeable) -instance Typeable input => Exception (ParseError input) +instance (Typeable input, Show input) => Exception (ParseError input) -instance Show (ParseError input) where +instance Show input => Show (ParseError input) where show (NotEnough (CountOf sz)) = "NotEnough: missing " <> show sz <> " element(s)" show NotEnoughParseOnly = "NotEnough, parse only" show (ExpectedElement _ _) = "Expected _ but received _" @@ -95,6 +97,14 @@ show (Satisfy Nothing) = "Satisfy" show (Satisfy (Just s)) = "Satisfy: " <> toList s +instance {-# OVERLAPPING #-} Show (ParseError String) where + show (NotEnough (CountOf sz)) = "NotEnough: missing " <> show sz <> " element(s)" + show NotEnoughParseOnly = "NotEnough, parse only" + show (ExpectedElement a b) = "Expected "<>show a<>" but received " <> show b + show (Expected a b) = "Expected "<>show a<>" but received " <> show b + show (Satisfy Nothing) = "Satisfy" + show (Satisfy (Just s)) = "Satisfy: " <> toList s + -- Results -------------------------------------------------------------------- -- | result of executing the `parser` over the given `input` @@ -107,7 +117,7 @@ -- ^ the parser needs more input, pass an empty @Chunk@ or @mempty@ -- to tell the parser you don't have anymore inputs. -instance Show k => Show (Result input k) where +instance (Show k, Show input) => Show (Result input k) where show (ParseFailed err) = "Parser failed: " <> show err show (ParseOk _ k) = "Parser succeed: " <> show k show (ParseMore _) = "Parser incomplete: need more" @@ -300,6 +310,19 @@ Nothing -> err buf off nm $ NotEnough 1 Just x -> ok buf (succ off) nm x {-# INLINE anyElement #-} + +-- | peek the first element from the input source without consuming it +-- +-- Returns 'Nothing' if there is no more input to parse. +-- +peek :: ParserSource input => Parser input (Maybe (Element input)) +peek = Parser $ \buf off nm err ok -> + case buf ! off of + Nothing -> runParser_ peekOnly buf off nm err ok + Just x -> ok buf off nm (Just x) + where + peekOnly = Parser $ \buf off nm _ ok -> + ok buf off nm (buf ! off) element :: ( ParserSource input , Eq (Element input) diff --git a/Foundation/Time/Types.hs b/Foundation/Time/Types.hs --- a/Foundation/Time/Types.hs +++ b/Foundation/Time/Types.hs @@ -5,6 +5,7 @@ -- -- An implementation of a timing framework -- +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Time.Types ( NanoSeconds(..) @@ -21,7 +22,9 @@ newtype NanoSeconds = NanoSeconds Word64 deriving (Show,Eq,Ord,Additive,Enum,Bounded) + instance PrimType NanoSeconds where + type PrimSize NanoSeconds = 8 primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy Word64) primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy Word64) primBaUIndex ba ofs = primBaUIndex ba (coerce ofs) @@ -36,6 +39,7 @@ deriving (Show,Eq,Ord,Additive,Enum,Bounded) instance PrimType Seconds where + type PrimSize Seconds = 8 primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy Word64) primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy Word64) primBaUIndex ba ofs = primBaUIndex ba (coerce ofs) diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,154 +0,0 @@ -Foundation -========== - -[![Linux Build Status](https://img.shields.io/travis/haskell-foundation/foundation/master.svg?label=Linux%20build)](https://travis-ci.org/haskell-foundation/foundation) -[![Windows Build Status](https://img.shields.io/appveyor/ci/vincenthz/foundation/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/vincenthz/foundation/branch/master) -[![Doc](https://readthedocs.org/projects/haskell-foundation/badge/?version=latest)](http://haskell-foundation.readthedocs.io/en/latest/) -[![Stackage version](https://www.stackage.org/package/foundation/badge/lts?label=Stackage)](https://www.stackage.org/package/foundation) -[![Hackage version](https://img.shields.io/hackage/v/foundation.svg?label=Hackage)](https://hackage.haskell.org/package/foundation) -[![BSD3](https://img.shields.io/badge/License-BSD-blue.svg)](https://en.wikipedia.org/wiki/BSD_License) -[![Haskell](https://img.shields.io/badge/Language-Haskell-yellowgreen.svg)](https://www.haskell.org) -[![Coverage Status](https://coveralls.io/repos/github/haskell-foundation/foundation/badge.svg?branch=master)](https://coveralls.io/github/haskell-foundation/foundation?branch=master) - -Documentation: - -* [Read the doc](http://haskell-foundation.readthedocs.io/en/latest/) -* [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 -===== - -* provide a base like set of modules that provide a consistent set of features and bugfixes across multiple versions of GHC (unlike base). -* provide a better and more efficient prelude than base's prelude. -* be self-sufficient: no external dependencies apart from base (or ghc packages). -* provide better data-types: packed unicode string by default, arrays. -* Better numerical classes that better represent mathematical things (No more all-in-one Num). - -Usage -===== - -How to use with the normal Prelude ----------------------------------- - -Add the `foundation` package in your cabal file, and it's recommended to import Foundation qualified if -you're planning to use with the normal Prelude: - -For example: - -```haskell -import qualified Foundation as F -``` - -It's also recommended if you're going to deal with packages using text, bytestring, vector.. to use -the `foundation-edge` package. - -How to use fully without Prelude --------------------------------- - -Disable the built-in prelude at the top of your file: - -```haskell -{-# LANGUAGE NoImplicitPrelude #-} -``` - -Or directly in your project cabal file: - -```haskell -Default-Extensions: NoImplicitPrelude -``` - -Then in your modules: - -```haskell -import Foundation -``` - -Advanced settings ----------------------- - -Please check out the chapter [Advanced Usage Options](docs/advanced-runtime.md) in the -documentation. - - -How to contribute -================= - -Contribution guide can be found -[here](http://haskell-foundation.readthedocs.io/en/latest/contributing/). - - -Profiling ---------- - -If you want to see the core (simpl step) or the assembly (asm step), then you can build with - - stack build --ghc-options -ddump-simpl --ghc-options -ddump-asm - -Note that it doesn't actually will create the necessary extra files if the modules doesn't need building. - -you can then find your build by-products in: - - .stack-work/dist//Cabal-/build/ - -Each modules that get compiled will create an equivalent file in the build directory: - -* ModuleName.dump-simpl -* ModuleName.dump-asm - -For profiling individual programs, the following command is useful: - - stack ghc -- -O --make X.hs -prof -auto-all -caf-all -fforce-recomp - -Benchmarking ------------- - -To get the list of benchmark: - - stack bench --benchmark-arguments -l - -To compare against other libraries, you need to set the `bench-all` flag - - stack bench --flag foundation:bench-all --benchmark-arguments -l - -To run a specific or set of benchmarks : - - stack bench --flag foundation:bench-all --benchmark-arguments 'types/String/SplitAt/mascii-10/Text' - stack bench --flag foundation:bench-all --benchmark-arguments '-m prefix types/String/SplitAt' - stack bench --flag foundation:bench-all --benchmark-arguments '-m glob types/String/SplitAt' - -To register a set of benchmarks: - - stack bench --flag foundation:bench-all --benchmark-arguments "--csv $(git describe).csv" - - -Design -====== - -Foundation started on the simple idea of trying to put everything I need in one -simple and consistent package. The amazing haskell ecosystem is extremely -fragmented and maintained by different people with different goals, free time, -and style. The overall scare of not trying to change anything relatively -central (`base`, `bytestring`, `text`, `vector`, ...) for a promise of stability -has pushed many people to work on their own thing, leading to unnecessary work -duplication and further fragmentation. - - -Foundation uses and abuses type families. - - -Code Organisation -================= - -Every foundation modules start by `Foundation`. - -* `Foundation` is the prelude replacement module. -* `Basement.Compat` contains only compatibilty and re-export from ghc/ghc-prim/base. -* `Foundation.Primitive` is where all the lowlevel magic happens: - * Important types that underpins many others part - * Pervasive features diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/foundation.cabal b/foundation.cabal --- a/foundation.cabal +++ b/foundation.cabal @@ -1,5 +1,5 @@ name: foundation -version: 0.0.20 +version: 0.0.21 synopsis: Alternative prelude with batteries and no dependencies description: A custom prelude with no dependencies apart from base. @@ -29,14 +29,12 @@ homepage: https://github.com/haskell-foundation/foundation bug-reports: https://github.com/haskell-foundation/foundation/issues cabal-version: >=1.18 -tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3 extra-source-files: cbits/*.h -extra-doc-files: README.md - CHANGELOG.md source-repository head type: git location: https://github.com/haskell-foundation/foundation + subdir: foundation flag experimental description: Enable building experimental features, known as highly unstable or without good support cross-platform @@ -96,6 +94,7 @@ Foundation.Collection Foundation.Primitive Foundation.List.DList + Foundation.List.ListN Foundation.Monad Foundation.Monad.Except Foundation.Monad.Reader @@ -113,6 +112,7 @@ Foundation.Time.Types Foundation.Time.Bindings Foundation.Time.StopWatch + Foundation.Tuple.Nth Foundation.UUID Foundation.System.Entropy Foundation.System.Bindings @@ -142,6 +142,9 @@ Foundation.Collection.Zippable Foundation.Collection.Mappable Foundation.Conduit.Internal + Foundation.Format.CSV.Types + Foundation.Format.CSV.Builder + Foundation.Format.CSV.Parser Foundation.Numerical.Floating Foundation.IO.File Foundation.Monad.MonadIO @@ -187,18 +190,22 @@ if os(osx) exposed-modules: Foundation.System.Bindings.Macos - if impl(ghc >= 7.10) - exposed-modules: Foundation.Tuple.Nth - Foundation.List.ListN - default-extensions: NoImplicitPrelude RebindableSyntax TypeFamilies BangPatterns DeriveDataTypeable - build-depends: base >= 4.7 && < 5 - , basement == 0.0.7 + + if impl(ghc < 8.0) + buildable: False + else + build-depends: base , ghc-prim + if os(windows) + build-depends: Win32 + + build-depends: basement == 0.0.8 + -- FIXME add suport for armel mipsel -- CPP-options: -DARCH_IS_LITTLE_ENDIAN -- FIXME add support for powerpc powerpc64 armeb mipseb @@ -207,8 +214,6 @@ cpp-options: -DARCH_IS_LITTLE_ENDIAN else cpp-options: -DARCH_IS_UNKNOWN_ENDIAN - if os(windows) - build-depends: Win32 ghc-options: -Wall -fwarn-tabs default-language: Haskell2010 if impl(ghc >= 8.0) @@ -230,6 +235,8 @@ Test.Foundation.String.Base64 Test.Foundation.String Test.Foundation.Bits + Test.Basement + Test.Basement.UTF8 Test.Data.Network Test.Data.List Test.Foundation.Network.IPv4 @@ -239,7 +246,7 @@ default-extensions: NoImplicitPrelude RebindableSyntax OverloadedStrings - build-depends: base >= 3 && < 5 + build-depends: base , basement , foundation ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures @@ -274,7 +281,7 @@ buildable: False else if flag(doctest) - build-depends: base >= 3 && < 5 + build-depends: base , doctest >= 0.9 buildable: True else @@ -296,7 +303,7 @@ if flag(minimal-deps) || impl(ghc < 7.10) buildable: False else - build-depends: base >= 4, gauge, basement, foundation + build-depends: base, 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 @@ -30,6 +30,7 @@ import Test.Checks.Property.Collection import Test.Foundation.Format import qualified Test.Foundation.Bits as Bits +import qualified Test.Basement as Basement #if MIN_VERSION_base(4,9,0) import Test.Foundation.Primitive.BlockN @@ -110,6 +111,7 @@ ] , Group "Number" testNumberRefs ] + , Basement.tests , Bits.tests , Group "String" [ Group "reading" diff --git a/tests/Test/Basement.hs b/tests/Test/Basement.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Basement.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Basement + ( tests + ) where + +import Foundation +import Foundation.Check +import qualified Test.Basement.UTF8 as UTF8 + +tests = Group "basement" + [ UTF8.tests + ] diff --git a/tests/Test/Basement/UTF8.hs b/tests/Test/Basement/UTF8.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Basement/UTF8.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Basement.UTF8 + ( tests ) + where + +import Basement.Types.CharUTF8 +import Foundation +import Foundation.Check +import Foundation.String + +tests = Group "utf8" + [ Property "CharUTF8" $ \c -> decodeCharUTF8 (encodeCharUTF8 c) === c + ] diff --git a/tests/Test/Foundation/Bits.hs b/tests/Test/Foundation/Bits.hs --- a/tests/Test/Foundation/Bits.hs +++ b/tests/Test/Foundation/Bits.hs @@ -1,10 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Test.Foundation.Bits ( tests ) where +import Basement.Cast import Foundation.Bits import Foundation.Check import Foundation @@ -16,7 +18,7 @@ arbitrary = Shifter . applyMod <$> arbitrary where applyMod i = abs i `mod` 256 -testBits :: forall a . (Integral a, IsIntegral a, Bits a, Show a, Eq a, Arbitrary a, Typeable a) +testBits :: forall a . (Additive a, Bounded a, Difference a ~ a, Integral a, IsIntegral a, Bits a, Show a, Subtractive a, Eq a, Arbitrary a, Typeable a) => String -> Proxy a -> Gen a @@ -26,6 +28,21 @@ (a `shiftR` i) === convertBack (toInteger a `shiftR` i) , Property "shiftL" $ \(a :: a) (Shifter i) -> (a `shiftL` i) === convertBack (toInteger a `shiftL` i) + , Property "maxBound value" $ \(a :: a) -> + case bitSizeMaybe a of + Just bs -> + let actualMaxBound :: a + actualMaxBound = maxBound + expectedMaxBound :: Integer + expectedMaxBound = 2^(cast bs :: Word) - (1 :: Integer) + in toInteger actualMaxBound === expectedMaxBound + Nothing -> propertyFail "Expected FiniteBits" + , Property "complement maxBound" $ + complement 0 === (maxBound :: a) + , Property "overflow maxBound" $ + maxBound + 1 === (0 :: a) + , Property "underflow zero" $ + (0 :: a) - 1 === maxBound ] where convertBack x diff --git a/tests/Test/Foundation/Format/CSV.hs b/tests/Test/Foundation/Format/CSV.hs --- a/tests/Test/Foundation/Format/CSV.hs +++ b/tests/Test/Foundation/Format/CSV.hs @@ -1,5 +1,8 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + module Test.Foundation.Format.CSV ( testFormatCSV ) where @@ -8,18 +11,42 @@ import Foundation.Format.CSV import Foundation.Check import Foundation.String.Builder (toString) +import Foundation.Parser (parseOnly) +import Data.Typeable + testFormatCSV :: Test testFormatCSV = Group "CSV" [ Group "field unit tests" $ testFieldEncoding <$> fieldUnitTests , Group "row unit tests" $ testRowEncoding <$> rowUnitTests + , Group "row unit tests" $ testRowDecoding <$> rowUnitTests + , Group "record . toRow == id" + [ pTest (Proxy @(Bool, Bool)) + , pTest (Proxy @(Int8, Word32, Natural)) + , pTest (Proxy @(Int, String, Word256, Word128)) + , pTest (Proxy @(Word8, String, Bool, Int64, String)) + ] ] where + pTest :: (Arbitrary a, Record a, Typeable a, Show a, Eq a) => Proxy a -> Test + pTest p = Property (show $ typeRep p) (go p) + where + go :: (Arbitrary a, Record a, Typeable a, Show a, Eq a) => Proxy a -> a -> PropertyCheck + go _ t = + let row = (toRow t) + str = toString $ rowStringBuilder row + in case parseOnly record_ str of + Left err -> propertyFail $ show err + Right v -> t === v testFieldEncoding (f,r) = Property (show f) $ let str = toString (fieldStringBuilder f) in r === str - testRowEncoding (row,result) = Property (show row) $ + testRowDecoding (r, row,result) = Property (show r) $ + case parseOnly record result of + Left err -> propertyFail (show err) + Right v -> row === v + testRowEncoding (row, _,result) = Property (show row) $ let str = toString (rowStringBuilder row) in result === str @@ -36,14 +63,24 @@ , (string "supported sizes are: 12\", 13\" and 14\"", "\"supported sizes are: 12\"\", 13\"\" and 14\"\"\"") ] -rowUnitTests :: [(Row, String)] +rowUnitTests :: [(Row, Row, String)] rowUnitTests = - [ (fromList [toField (42 :: Int), toField ("some string" :: String)], "42,some string") - , (toRow (42 :: Int, "some string" :: String), "42,some string") + [ ( fromList [toField (42 :: Int), toField ("some string" :: String)] + , fromList [toField ("42" :: String), toField ("some string" :: String)] + , "42,some string" + ) + , ( toRow (42 :: Int, "some string" :: String) + , toRow ("42" :: String, "some string" :: String) + , "42,some string" + ) , ( toRow ( 42 :: Int , "some string" :: String , "supported sizes are: 12\", 13\" and 14\"" :: String ) + , toRow ( "42" :: String + , "some string" :: String + , "supported sizes are: 12\", 13\" and 14\"" :: String + ) , "42,some string,\"supported sizes are: 12\"\", 13\"\" and 14\"\"\"" ) , ( toRow ( 42 :: Int @@ -51,6 +88,11 @@ , "supported sizes are: 12\", 13\" and 14\"" :: String , Just 0.000001 :: Maybe Double ) + , toRow ( "42" :: String + , "some string" :: String + , "supported sizes are: 12\", 13\" and 14\"" :: String + , Just "1.0e-6" :: Maybe String + ) , "42,some string,\"supported sizes are: 12\"\", 13\"\" and 14\"\"\",1.0e-6" ) , ( toRow ( 42 :: Int @@ -59,6 +101,28 @@ , Just 0.000001 :: Maybe Double , Nothing :: Maybe Char ) + , toRow ( "42" :: String + , "some string" :: String + , "supported sizes are: 12\", 13\" and 14\"" :: String + , Just "1.0e-6" :: Maybe String + , Nothing :: Maybe String + ) , "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 + , "with £ € ¥" :: String + ) + , toRow ( "42" :: String + , "some string" :: String + , "supported sizes are: 12\", 13\" and 14\"" :: String + , Just "1.0e-6" :: Maybe String + , Nothing :: Maybe String + , "with £ € ¥" :: String + ) + , "42,some string,\"supported sizes are: 12\"\", 13\"\" and 14\"\"\",1.0e-6,,with £ € ¥" ) ]