futhark-data-1.1.0.1/0000755000000000000000000000000007346545000012414 5ustar0000000000000000futhark-data-1.1.0.1/CHANGELOG.md0000644000000000000000000000131707346545000014227 0ustar0000000000000000# Revision history for futhark-data ## 1.1.0.1 -- 2023-03-21 * Minor fix for GHC 9.6 changes. ## 1.1.0.0 -- 2022-05-02 * String literals are now supported in the textual value format. * The `PutValue1` typeclass now has instances for `Text` and `ByteString`. ## 1.0.3.0 -- 2021-12-06 * The `GetValue [t]` instance no longer produces an empty list on any non-array type. * New typeclass `PutValue1` as a version of `PutValue` that cannot fail. ## 1.0.2.0 -- 2021-08-12 * Support underscores in numeric literals. ## 1.0.1.1 -- 2021-08-04 * Support the `f16` type. ## 1.0.0.1 -- 2021-06-09 * Fixed crash in value comparison. ## 1.0.0.0 -- 2021-06-08 * First version. Released on an unsuspecting world. futhark-data-1.1.0.1/LICENSE0000644000000000000000000000137707346545000013431 0ustar0000000000000000ISC License Copyright (c) 2013-2021. DIKU, University of Copenhagen Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. futhark-data-1.1.0.1/futhark-data.cabal0000644000000000000000000000450007346545000015752 0ustar0000000000000000cabal-version: 2.4 name: futhark-data version: 1.1.0.1 synopsis: An implementation of the Futhark data format. description: The Futhark compiler and its tools uses a simple external data representation to encode arrays and scalars. This package implements both a Haskell-level representation of these values, as well as utility functions for reading and writing values in both the textual and binary format. category: Futhark author: Troels Henriksen maintainer: athas@sigkill.dk bug-reports: https://github.com/diku-dk/futhark-data-haskell/issues license: ISC license-file: LICENSE extra-source-files: CHANGELOG.md source-repository head type: git location: https://github.com/diku-dk/futhark-data-haskell library exposed-modules: Futhark.Data , Futhark.Data.Compare , Futhark.Data.Reader , Futhark.Data.Parser build-depends: base >=4 && < 5 , binary >=0.8.3 , bytestring >=0.10.8 , bytestring-to-vector >=0.3.0.1 , containers >=0.6.2.1 , half >= 0.3 , megaparsec >=9.0.0 , mtl >=2.2.1 , scientific >=0.3.6 , text >=1.2.2.2 , vector >=0.12 , vector-binary-instances >=0.2.2.0 hs-source-dirs: src ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists default-language: Haskell2010 test-suite futhark-data-test default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Tests.hs hs-source-dirs: tests ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: base >=4 && < 5 , binary >=0.8.3 , bytestring >=0.10.8 , futhark-data , megaparsec >=9.0.0 , QuickCheck >=2.8 , tasty , tasty-hunit , tasty-quickcheck , text >=1.2.2.2 , vector >=0.12 futhark-data-1.1.0.1/src/Futhark/0000755000000000000000000000000007346545000014607 5ustar0000000000000000futhark-data-1.1.0.1/src/Futhark/Data.hs0000644000000000000000000004054407346545000016023 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} -- | This module defines an efficient value representation of the -- Futhark data format. module Futhark.Data ( Value (..), Vector, valueText, -- * Types of values PrimType (..), primTypeText, primTypeBytes, ValueType (..), valueTypeTextNoDims, valueType, valueElemType, valueShape, valueTypeText, -- * Converting values GetValue (..), PutValue (..), PutValue1 (..), valueElems, ) where import Control.Monad import Data.Binary import Data.Binary.Get import Data.Binary.Put import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char (chr, ord) import Data.Int (Int16, Int32, Int64, Int8) import Data.List (intersperse) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as TB import qualified Data.Vector.Storable as SVec import Data.Vector.Storable.ByteString (byteStringToVector, vectorToByteString) import Numeric.Half -- | The value vector type. type Vector = SVec.Vector -- | An efficiently represented Futhark value, represented as a shape -- vector and a value vector, which contains elements in row-major -- order. The size of the value vector must be equal to the product -- of the shape vector. This is not enforced by the representation, -- but consuming functions may give unexpected results if this -- invariant is broken. Scalars are represented with an empty shape -- vector. -- -- Use 'valueText' to get a human-readable representation, and v'put' -- to obtain binary a representation. -- -- The 'Eq' instance is the naive one, meaning that no values -- containing NaNs will be considered equal. Use the functions from -- "Futhark.Data.Compare" if this is not what you want. data Value = I8Value (Vector Int) (Vector Int8) | I16Value (Vector Int) (Vector Int16) | I32Value (Vector Int) (Vector Int32) | I64Value (Vector Int) (Vector Int64) | U8Value (Vector Int) (Vector Word8) | U16Value (Vector Int) (Vector Word16) | U32Value (Vector Int) (Vector Word32) | U64Value (Vector Int) (Vector Word64) | F16Value (Vector Int) (Vector Half) | F32Value (Vector Int) (Vector Float) | F64Value (Vector Int) (Vector Double) | BoolValue (Vector Int) (Vector Bool) deriving (Eq, Show) binaryFormatVersion :: Word8 binaryFormatVersion = 2 instance Binary Value where put (I8Value shape vs) = putBinaryValue " i8" shape vs put (I16Value shape vs) = putBinaryValue " i16" shape vs put (I32Value shape vs) = putBinaryValue " i32" shape vs put (I64Value shape vs) = putBinaryValue " i64" shape vs put (U8Value shape vs) = putBinaryValue " u8" shape vs put (U16Value shape vs) = putBinaryValue " u16" shape vs put (U32Value shape vs) = putBinaryValue " u32" shape vs put (U64Value shape vs) = putBinaryValue " u64" shape vs put (F16Value shape vs) = putBinaryValue " f16" shape vs put (F32Value shape vs) = putBinaryValue " f32" shape vs put (F64Value shape vs) = putBinaryValue " f64" shape vs -- Bool must be treated specially because the Storable instance -- uses four bytes. put (BoolValue shape vs) = putBinaryValue "bool" shape $ SVec.map boolToInt8 vs where boolToInt8 True = 1 :: Int8 boolToInt8 False = 0 get = do first <- getInt8 version <- getWord8 rank <- getInt8 unless (chr (fromIntegral first) == 'b') $ fail "Input does not begin with ASCII 'b'." unless (version == binaryFormatVersion) $ fail $ "Expecting binary format version 1; found version: " ++ show version unless (rank >= 0) $ fail $ "Rank must be non-negative, but is: " ++ show rank type_f <- getLazyByteString 4 shape <- replicateM (fromIntegral rank) $ fromIntegral <$> getInt64le let num_elems = product shape shape' = SVec.fromList shape case LBS.unpack type_f of " i8" -> get' (I8Value shape') num_elems 1 " i16" -> get' (I16Value shape') num_elems 2 " i32" -> get' (I32Value shape') num_elems 4 " i64" -> get' (I64Value shape') num_elems 8 " u8" -> get' (U8Value shape') num_elems 1 " u16" -> get' (U16Value shape') num_elems 2 " u32" -> get' (U32Value shape') num_elems 4 " u64" -> get' (U64Value shape') num_elems 8 " f16" -> get' (F16Value shape') num_elems 2 " f32" -> get' (F32Value shape') num_elems 4 " f64" -> get' (F64Value shape') num_elems 8 -- Bool must be treated specially because the Storable instance -- uses four bytes. "bool" -> BoolValue shape' . SVec.map int8ToBool . byteStringToVector . BS.copy <$> getByteString num_elems s -> fail $ "Cannot parse binary values of type " ++ show s where -- The copy is to ensure that the bytestring is properly -- aligned. get' mk num_elems elem_size = mk . byteStringToVector . BS.copy <$> getByteString (num_elems * elem_size) int8ToBool :: Int8 -> Bool int8ToBool = (/= 0) putBinaryValue :: SVec.Storable a => String -> Vector Int -> Vector a -> Put putBinaryValue tstr shape vs = do putInt8 $ fromIntegral $ ord 'b' putWord8 binaryFormatVersion putWord8 $ fromIntegral $ SVec.length shape mapM_ (putInt8 . fromIntegral . ord) tstr putByteString $ vectorToByteString shape putByteString $ vectorToByteString vs arrayText :: (SVec.Storable a) => (a -> TB.Builder) -> [Int] -> SVec.Vector a -> TB.Builder arrayText p [] vs = p $ SVec.head vs arrayText p (d : ds) vs = "[" <> mconcat (intersperse separator $ map (arrayText p ds . slice) [0 .. d - 1]) <> "]" where slice_size = product ds slice i = SVec.slice (i * slice_size) slice_size vs separator | null ds = ", " | otherwise = ",\n" -- | Construct a textual representation of the value as a strict text. valueText :: Value -> T.Text valueText v | product (valueShape v) == 0 = "empty(" <> dims <> primTypeText (valueElemType v) <> ")" where dims = mconcat $ map (brackets . T.pack . show) $ valueShape v brackets s = "[" <> s <> "]" valueText v = case v of I8Value shape vs -> f pNum shape vs I16Value shape vs -> f pNum shape vs I32Value shape vs -> f pNum shape vs I64Value shape vs -> f pNum shape vs U8Value shape vs -> f pNum shape vs U16Value shape vs -> f pNum shape vs U32Value shape vs -> f pNum shape vs U64Value shape vs -> f pNum shape vs F16Value shape vs -> f pF16 shape vs F32Value shape vs -> f pF32 shape vs F64Value shape vs -> f pF64 shape vs BoolValue shape vs -> f pBool shape vs where suffix = primTypeText $ valueElemType v pNum x = TB.fromString (show x) <> TB.fromText suffix pF16 x | isInfinite x, x >= 0 = "f16.inf" | isInfinite x, x < 0 = "-f16.inf" | isNaN x = "f16.nan" | otherwise = pNum x pF32 x | isInfinite x, x >= 0 = "f32.inf" | isInfinite x, x < 0 = "-f32.inf" | isNaN x = "f32.nan" | otherwise = pNum x pF64 x | isInfinite x, x >= 0 = "f64.inf" | isInfinite x, x < 0 = "-f64.inf" | isNaN x = "f64.nan" | otherwise = pNum x pBool True = "true" pBool False = "false" f p shape vs = LT.toStrict $ TB.toLazyText $ arrayText p (SVec.toList shape) vs -- | The scalar types supported by the value format. data PrimType = I8 | I16 | I32 | I64 | U8 | U16 | U32 | U64 | F16 | F32 | F64 | Bool deriving (Eq, Ord, Show, Enum, Bounded) -- | Textual primitive type as a strict text. primTypeText :: PrimType -> T.Text primTypeText I8 = "i8" primTypeText I16 = "i16" primTypeText I32 = "i32" primTypeText I64 = "i64" primTypeText U8 = "u8" primTypeText U16 = "u16" primTypeText U32 = "u32" primTypeText U64 = "u64" primTypeText F16 = "f16" primTypeText F32 = "f32" primTypeText F64 = "f64" primTypeText Bool = "bool" -- | The number of bytes taken up by a single element of this type. primTypeBytes :: PrimType -> Int primTypeBytes I8 = 1 primTypeBytes I16 = 2 primTypeBytes I32 = 4 primTypeBytes I64 = 8 primTypeBytes U8 = 1 primTypeBytes U16 = 2 primTypeBytes U32 = 4 primTypeBytes U64 = 8 primTypeBytes F16 = 2 primTypeBytes F32 = 4 primTypeBytes F64 = 8 primTypeBytes Bool = 1 -- | The type of a simple Futhark value, comprising a shape and an -- element type. data ValueType = ValueType [Int] PrimType deriving (Eq, Ord, Show) -- | Prettyprint a value type as a strict text. valueTypeText :: ValueType -> T.Text valueTypeText (ValueType ds t) = mconcat (map pprDim ds) <> primTypeText t where pprDim d = "[" <> T.pack (show d) <> "]" -- | Prettyprint a value type with empty dimensions as a strict text. -- This is needed for Futhark server programs, whose types are -- un-sized. valueTypeTextNoDims :: ValueType -> T.Text valueTypeTextNoDims (ValueType dims t) = mconcat (replicate (length dims) "[]") <> primTypeText t -- | Get the type of a value. valueType :: Value -> ValueType valueType v = ValueType (valueShape v) $ valueElemType v -- | Get the element type of a value. valueElemType :: Value -> PrimType valueElemType I8Value {} = I8 valueElemType I16Value {} = I16 valueElemType I32Value {} = I32 valueElemType I64Value {} = I64 valueElemType U8Value {} = U8 valueElemType U16Value {} = U16 valueElemType U32Value {} = U32 valueElemType U64Value {} = U64 valueElemType F16Value {} = F16 valueElemType F32Value {} = F32 valueElemType F64Value {} = F64 valueElemType BoolValue {} = Bool -- | The shape of a value. Empty list in case of a scalar. valueShape :: Value -> [Int] valueShape (I8Value shape _) = SVec.toList shape valueShape (I16Value shape _) = SVec.toList shape valueShape (I32Value shape _) = SVec.toList shape valueShape (I64Value shape _) = SVec.toList shape valueShape (U8Value shape _) = SVec.toList shape valueShape (U16Value shape _) = SVec.toList shape valueShape (U32Value shape _) = SVec.toList shape valueShape (U64Value shape _) = SVec.toList shape valueShape (F16Value shape _) = SVec.toList shape valueShape (F32Value shape _) = SVec.toList shape valueShape (F64Value shape _) = SVec.toList shape valueShape (BoolValue shape _) = SVec.toList shape -- Conversions -- | Produce a list of the immediate elements of the value. That is, -- a 2D array will produce a list of 1D values. A zero-dimensional -- value will produce an empty list. While lists are of course -- inefficient, the actual values are just slices of the original -- value, which makes them fairly space-efficient (but beware space -- leaks). valueElems :: Value -> [Value] valueElems v | n : ns <- valueShape v = let k = product ns slices mk vs = [ mk (SVec.fromList ns) $ SVec.slice (k * i) k vs | i <- [0 .. n - 1] ] in case v of I8Value _ vs -> slices I8Value vs I16Value _ vs -> slices I16Value vs I32Value _ vs -> slices I32Value vs I64Value _ vs -> slices I64Value vs U8Value _ vs -> slices U8Value vs U16Value _ vs -> slices U16Value vs U32Value _ vs -> slices U32Value vs U64Value _ vs -> slices U64Value vs F16Value _ vs -> slices F16Value vs F32Value _ vs -> slices F32Value vs F64Value _ vs -> slices F64Value vs BoolValue _ vs -> slices BoolValue vs | otherwise = [] -- | A class for Haskell values that can be retrieved from 'Value'. -- This is a convenience facility - don't expect it to be fast. class GetValue t where getValue :: Value -> Maybe t instance GetValue t => GetValue [t] where getValue v | null $ valueShape v = Nothing | otherwise = mapM getValue $ valueElems v instance GetValue Bool where getValue (BoolValue shape vs) | [] <- SVec.toList shape = Just $ vs SVec.! 0 getValue _ = Nothing instance GetValue Int8 where getValue (I8Value shape vs) | [] <- SVec.toList shape = Just $ vs SVec.! 0 getValue _ = Nothing instance GetValue Int16 where getValue (I16Value shape vs) | [] <- SVec.toList shape = Just $ vs SVec.! 0 getValue _ = Nothing instance GetValue Int32 where getValue (I32Value shape vs) | [] <- SVec.toList shape = Just $ vs SVec.! 0 getValue _ = Nothing instance GetValue Int64 where getValue (I64Value shape vs) | [] <- SVec.toList shape = Just $ vs SVec.! 0 getValue _ = Nothing instance GetValue Word8 where getValue (U8Value shape vs) | [] <- SVec.toList shape = Just $ vs SVec.! 0 getValue _ = Nothing instance GetValue Word16 where getValue (U16Value shape vs) | [] <- SVec.toList shape = Just $ vs SVec.! 0 getValue _ = Nothing instance GetValue Word32 where getValue (U32Value shape vs) | [] <- SVec.toList shape = Just $ vs SVec.! 0 getValue _ = Nothing instance GetValue Word64 where getValue (U64Value shape vs) | [] <- SVec.toList shape = Just $ vs SVec.! 0 getValue _ = Nothing -- | A class for Haskell values that can be converted to 'Value'. -- This is a convenience facility - don't expect it to be fast. class PutValue t where -- | This may fail for cases such as irregular arrays. putValue :: t -> Maybe Value instance PutValue Int8 where putValue = Just . putValue1 instance PutValue Int16 where putValue = Just . putValue1 instance PutValue Int32 where putValue = Just . putValue1 instance PutValue Int64 where putValue = Just . putValue1 instance PutValue Word8 where putValue = Just . putValue1 instance PutValue Word16 where putValue = Just . putValue1 instance PutValue Word32 where putValue = Just . putValue1 instance PutValue Word64 where putValue = Just . putValue1 instance PutValue [Value] where putValue [] = Nothing putValue (x : xs) = do let res_shape = SVec.fromList $ length (x : xs) : valueShape x guard $ all ((== valueType x) . valueType) xs Just $ case x of I8Value {} -> I8Value res_shape $ foldMap getVec (x : xs) I16Value {} -> I16Value res_shape $ foldMap getVec (x : xs) I32Value {} -> I32Value res_shape $ foldMap getVec (x : xs) I64Value {} -> I64Value res_shape $ foldMap getVec (x : xs) U8Value {} -> U8Value res_shape $ foldMap getVec (x : xs) U16Value {} -> U16Value res_shape $ foldMap getVec (x : xs) U32Value {} -> U32Value res_shape $ foldMap getVec (x : xs) U64Value {} -> U64Value res_shape $ foldMap getVec (x : xs) F16Value {} -> F16Value res_shape $ foldMap getVec (x : xs) F32Value {} -> F32Value res_shape $ foldMap getVec (x : xs) F64Value {} -> F64Value res_shape $ foldMap getVec (x : xs) BoolValue {} -> BoolValue res_shape $ foldMap getVec (x : xs) where getVec (I8Value _ vec) = SVec.unsafeCast vec getVec (I16Value _ vec) = SVec.unsafeCast vec getVec (I32Value _ vec) = SVec.unsafeCast vec getVec (I64Value _ vec) = SVec.unsafeCast vec getVec (U8Value _ vec) = SVec.unsafeCast vec getVec (U16Value _ vec) = SVec.unsafeCast vec getVec (U32Value _ vec) = SVec.unsafeCast vec getVec (U64Value _ vec) = SVec.unsafeCast vec getVec (F16Value _ vec) = SVec.unsafeCast vec getVec (F32Value _ vec) = SVec.unsafeCast vec getVec (F64Value _ vec) = SVec.unsafeCast vec getVec (BoolValue _ vec) = SVec.unsafeCast vec instance PutValue T.Text where putValue = putValue . T.encodeUtf8 instance PutValue BS.ByteString where putValue bs = Just $ U8Value size $ byteStringToVector bs where size = SVec.fromList [fromIntegral (BS.length bs)] -- | Like 'PutValue', but only for scalars and a few other simple -- things that cannot fail. class PutValue1 t where putValue1 :: t -> Value instance PutValue1 Int8 where putValue1 = I8Value mempty . SVec.singleton instance PutValue1 Int16 where putValue1 = I16Value mempty . SVec.singleton instance PutValue1 Int32 where putValue1 = I32Value mempty . SVec.singleton instance PutValue1 Int64 where putValue1 = I64Value mempty . SVec.singleton instance PutValue1 Word8 where putValue1 = U8Value mempty . SVec.singleton instance PutValue1 Word16 where putValue1 = U16Value mempty . SVec.singleton instance PutValue1 Word32 where putValue1 = U32Value mempty . SVec.singleton instance PutValue1 Word64 where putValue1 = U64Value mempty . SVec.singleton instance PutValue1 T.Text where putValue1 = putValue1 . T.encodeUtf8 instance PutValue1 BS.ByteString where putValue1 bs = U8Value size $ byteStringToVector bs where size = SVec.fromList [fromIntegral (BS.length bs)] futhark-data-1.1.0.1/src/Futhark/Data/0000755000000000000000000000000007346545000015460 5ustar0000000000000000futhark-data-1.1.0.1/src/Futhark/Data/Compare.hs0000644000000000000000000001503007346545000017401 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | Facilities for comparing values for equality. While 'Eq' -- instances are defined, these are not useful when NaNs are involved, -- and do not *explain* the differences. module Futhark.Data.Compare ( compareValues, compareSeveralValues, Tolerance (..), Mismatch, ) where import Data.List (intersperse) import qualified Data.Text as T import qualified Data.Vector.Storable as SVec import Futhark.Data -- | Two values differ in some way. The 'Show' instance produces a -- human-readable explanation. data Mismatch = -- | The position the value number and a flat index -- into the array. PrimValueMismatch Int [Int] T.Text T.Text | ArrayShapeMismatch Int [Int] [Int] | TypeMismatch Int T.Text T.Text | ValueCountMismatch Int Int showText :: Show a => a -> T.Text showText = T.pack . show -- | A human-readable description of how two values are not the same. explainMismatch :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text explainMismatch i what got expected = "Value #" <> i <> ": expected " <> what <> expected <> ", got " <> got instance Show Mismatch where show (PrimValueMismatch vi [] got expected) = T.unpack $ explainMismatch (showText vi) "" got expected show (PrimValueMismatch vi js got expected) = T.unpack $ explainMismatch (showText vi <> " index [" <> mconcat (intersperse "," (map showText js)) <> "]") "" got expected show (ArrayShapeMismatch i got expected) = T.unpack $ explainMismatch (showText i) "array of shape " (showText got) (showText expected) show (TypeMismatch i got expected) = T.unpack $ explainMismatch (showText i) "value of type " got expected show (ValueCountMismatch got expected) = T.unpack $ "Expected " <> showText expected <> " values, got " <> showText got -- | The maximum relative tolerance used for comparing floating-point -- results. 0.002 (0.2%) is a fine default if you have no particular -- opinion. newtype Tolerance = Tolerance Double deriving (Eq, Ord, Show) toleranceFloat :: RealFloat a => Tolerance -> a toleranceFloat (Tolerance x) = fromRational $ toRational x -- | Compare two Futhark values for equality. compareValues :: Tolerance -> Value -> Value -> [Mismatch] compareValues tol = compareValue tol 0 -- | As 'compareValues', but compares several values. The two lists -- must have the same length. compareSeveralValues :: Tolerance -> [Value] -> [Value] -> [Mismatch] compareSeveralValues tol got expected | n /= m = [ValueCountMismatch n m] | otherwise = concat $ zipWith3 (compareValue tol) [0 ..] got expected where n = length got m = length expected unflattenIndex :: [Int] -> Int -> [Int] unflattenIndex = unflattenIndexFromSlices . drop 1 . sliceSizes where sliceSizes [] = [1] sliceSizes (n : ns) = product (n : ns) : sliceSizes ns unflattenIndexFromSlices [] _ = [] unflattenIndexFromSlices (size : slices) i = (i `quot` size) : unflattenIndexFromSlices slices (i - (i `quot` size) * size) compareValue :: Tolerance -> Int -> Value -> Value -> [Mismatch] compareValue tol i got_v expected_v | valueShape got_v == valueShape expected_v = case (got_v, expected_v) of (I8Value _ got_vs, I8Value _ expected_vs) -> compareNum got_vs expected_vs (I16Value _ got_vs, I16Value _ expected_vs) -> compareNum got_vs expected_vs (I32Value _ got_vs, I32Value _ expected_vs) -> compareNum got_vs expected_vs (I64Value _ got_vs, I64Value _ expected_vs) -> compareNum got_vs expected_vs (U8Value _ got_vs, U8Value _ expected_vs) -> compareNum got_vs expected_vs (U16Value _ got_vs, U16Value _ expected_vs) -> compareNum got_vs expected_vs (U32Value _ got_vs, U32Value _ expected_vs) -> compareNum got_vs expected_vs (U64Value _ got_vs, U64Value _ expected_vs) -> compareNum got_vs expected_vs (F16Value _ got_vs, F16Value _ expected_vs) -> compareFloat (tolerance (toleranceFloat tol) expected_vs) got_vs expected_vs (F32Value _ got_vs, F32Value _ expected_vs) -> compareFloat (tolerance (toleranceFloat tol) expected_vs) got_vs expected_vs (F64Value _ got_vs, F64Value _ expected_vs) -> compareFloat (tolerance (toleranceFloat tol) expected_vs) got_vs expected_vs (BoolValue _ got_vs, BoolValue _ expected_vs) -> compareGen compareBool got_vs expected_vs _ -> [TypeMismatch i (primTypeText $ valueElemType got_v) (primTypeText $ valueElemType expected_v)] | otherwise = [ArrayShapeMismatch i (valueShape got_v) (valueShape expected_v)] where unflatten = unflattenIndex (valueShape got_v) value :: Show a => a -> T.Text value = T.pack . show {-# INLINE compareGen #-} {-# INLINE compareNum #-} {-# INLINE compareFloat #-} {-# INLINE compareFloatElement #-} {-# INLINE compareElement #-} compareNum :: (SVec.Storable a, Eq a, Show a) => SVec.Vector a -> SVec.Vector a -> [Mismatch] compareNum = compareGen compareElement compareFloat :: (SVec.Storable a, RealFloat a, Show a) => a -> SVec.Vector a -> SVec.Vector a -> [Mismatch] compareFloat = compareGen . compareFloatElement compareGen cmp got expected = let l = SVec.length got check acc j | j < l = case cmp j (got SVec.! j) (expected SVec.! j) of Just mismatch -> check (mismatch : acc) (j + 1) Nothing -> check acc (j + 1) | otherwise = acc in reverse $ check [] 0 compareElement :: (Show a, Eq a) => Int -> a -> a -> Maybe Mismatch compareElement j got expected | got == expected = Nothing | otherwise = Just $ PrimValueMismatch i (unflatten j) (value got) (value expected) compareFloatElement :: (Show a, RealFloat a) => a -> Int -> a -> a -> Maybe Mismatch compareFloatElement abstol j got expected | isNaN got, isNaN expected = Nothing | isInfinite got, isInfinite expected, signum got == signum expected = Nothing | abs (got - expected) <= abstol = Nothing | otherwise = Just $ PrimValueMismatch i (unflatten j) (value got) (value expected) compareBool j got expected | got == expected = Nothing | otherwise = Just $ PrimValueMismatch i (unflatten j) (value got) (value expected) tolerance :: (RealFloat a, SVec.Storable a) => a -> Vector a -> a tolerance tol = SVec.foldl tolerance' tol . SVec.filter (not . nanOrInf) where tolerance' t v = max t $ tol * v nanOrInf x = isInfinite x || isNaN x futhark-data-1.1.0.1/src/Futhark/Data/Parser.hs0000644000000000000000000001611707346545000017256 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | Megaparsec-based parser for 'Value's in the textual value format. -- The difference between this and the reader defined in -- "Futhark.Data.Reader" is that we don't try to handle both the -- textual and binary format - only the former. On the other hand, -- this parser has (much) better error messages and can be easily used -- by other parsers (like the ones for FutharkScript or test blocks). module Futhark.Data.Parser ( parsePrimType, parseType, parsePrimValue, parseValue, ) where import Control.Monad (unless) import Data.Char (digitToInt, isDigit, isHexDigit) import Data.Functor import qualified Data.Scientific as Sci import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Vector.Storable as SVec import Data.Void import Futhark.Data import Text.Megaparsec import Text.Megaparsec.Char (char) import Text.Megaparsec.Char.Lexer (charLiteral, signed) import Prelude hiding (exponent) -- | Parse the name of a primitive type. Does *not* consume any -- trailing whitespace, nor does it permit any internal whitespace. parsePrimType :: Parsec Void T.Text PrimType parsePrimType = choice [ "i8" $> I8, "i16" $> I16, "i32" $> I32, "i64" $> I64, "u8" $> U8, "u16" $> U16, "u32" $> U32, "u64" $> U64, "f16" $> F16, "f32" $> F32, "f64" $> F64, "bool" $> Bool ] allowUnderscores :: String -> (Char -> Bool) -> Parsec Void T.Text T.Text allowUnderscores desc p = T.filter (/= '_') <$> ( (<>) <$> takeWhile1P (Just desc) p <*> takeWhileP (Just descOrUnderscore) pOrUnderscore ) where descOrUnderscore = desc <> " or underscore" pOrUnderscore c = p c || c == '_' -- Adapted from megaparsec. decimal :: Num a => Parsec Void T.Text a decimal = mkNum <$> allowUnderscores "digit" isDigit where mkNum = T.foldl' step 0 step a c = a * 10 + fromIntegral (digitToInt c) -- Adapted from megaparsec. binary :: Num a => Parsec Void T.Text a binary = mkNum <$> allowUnderscores "binary digit" isBinDigit where mkNum = T.foldl' step 0 step a c = a * 2 + fromIntegral (digitToInt c) isBinDigit x = x == '0' || x == '1' -- Adapted from megaparsec. hexadecimal :: Num a => Parsec Void T.Text a hexadecimal = mkNum <$> allowUnderscores "hexadecimal digit" isHexDigit where mkNum = T.foldl' step 0 step a c = a * 16 + fromIntegral (digitToInt c) parseInteger :: Parsec Void T.Text Integer parseInteger = signed (pure ()) $ choice [ "0b" *> binary, "0x" *> hexadecimal, decimal ] scalar :: SVec.Storable a => (Vector Int -> Vector a -> Value) -> a -> Value scalar f x = f mempty (SVec.singleton x) parseIntConst :: Parsec Void T.Text Value parseIntConst = do x <- parseInteger notFollowedBy $ choice ["f16", "f32", "f64", ".", "e"] choice [ intV I8Value x "i8", intV I16Value x "i16", intV I32Value x "i32", intV I64Value x "i64", intV U8Value x "u8", intV U16Value x "u16", intV U32Value x "u32", intV U64Value x "u64", intV I32Value x "" ] where intV mk x suffix = suffix $> scalar mk (fromInteger x) -- Adapted from megaparsec. float :: RealFloat a => Parsec Void T.Text a float = do c' <- decimal Sci.toRealFloat <$> ( ( do (c, e') <- dotDecimal c' e <- option e' $ try $ exponent e' pure $ Sci.scientific c e ) <|> (Sci.scientific c' <$> exponent 0) ) where exponent e' = do void $ choice ["e", "E"] (+ e') <$> signed (pure ()) decimal dotDecimal c' = do void "." mkNum <$> allowUnderscores "digit" isDigit where mkNum = T.foldl' step (c', 0) step (a, e') c = (a * 10 + fromIntegral (digitToInt c), e' - 1) parseFloatConst :: Parsec Void T.Text Value parseFloatConst = choice [ "f16.nan" $> scalar F16Value (0 / 0), "f32.nan" $> scalar F32Value (0 / 0), "f64.nan" $> scalar F64Value (0 / 0), -- "f16.inf" $> scalar F16Value (1 / 0), "f32.inf" $> scalar F32Value (1 / 0), "f64.inf" $> scalar F64Value (1 / 0), -- "-f16.inf" $> scalar F16Value (-1 / 0), "-f32.inf" $> scalar F32Value (-1 / 0), "-f64.inf" $> scalar F64Value (-1 / 0), numeric ] where numeric = do x <- signed (pure ()) $ choice [try float, fromInteger <$> decimal] choice [ floatV F16Value x "f16", floatV F32Value x "f32", floatV F64Value x "f64", floatV F64Value x "" ] floatV mk x suffix = suffix $> scalar mk (realToFrac (x :: Double)) -- | Parse a primitive value. Does *not* consume any trailing -- whitespace, nor does it permit any internal whitespace. parsePrimValue :: Parsec Void T.Text Value parsePrimValue = choice [ try parseIntConst, parseFloatConst, "true" $> BoolValue mempty (SVec.singleton True), "false" $> BoolValue mempty (SVec.singleton False) ] parseStringConst :: Parsec Void T.Text Value parseStringConst = char '"' *> (putValue1 . T.pack <$> manyTill charLiteral (char '"')) lexeme :: Parsec Void T.Text () -> Parsec Void T.Text a -> Parsec Void T.Text a lexeme sep p = p <* sep inBrackets :: Parsec Void T.Text () -> Parsec Void T.Text a -> Parsec Void T.Text a inBrackets sep = between (lexeme sep "[") (lexeme sep "]") -- | Parse a type. Does *not* consume any trailing whitespace, nor -- does it permit any internal whitespace. parseType :: Parsec Void T.Text ValueType parseType = ValueType <$> many parseDim <*> parsePrimType where parseDim = fromInteger <$> ("[" *> parseInteger <* "]") parseEmpty :: Parsec Void T.Text Value parseEmpty = do ValueType dims t <- parseType unless (product dims == 0) $ fail "Expected at least one empty dimension" pure $ case t of I8 -> I8Value (SVec.fromList dims) mempty I16 -> I16Value (SVec.fromList dims) mempty I32 -> I32Value (SVec.fromList dims) mempty I64 -> I64Value (SVec.fromList dims) mempty U8 -> U8Value (SVec.fromList dims) mempty U16 -> U16Value (SVec.fromList dims) mempty U32 -> U32Value (SVec.fromList dims) mempty U64 -> U64Value (SVec.fromList dims) mempty F16 -> F16Value (SVec.fromList dims) mempty F32 -> F32Value (SVec.fromList dims) mempty F64 -> F64Value (SVec.fromList dims) mempty Bool -> BoolValue (SVec.fromList dims) mempty -- | Parse a value, given a post-lexeme parser for whitespace. parseValue :: Parsec Void T.Text () -> Parsec Void T.Text Value parseValue sep = choice [ lexeme sep parsePrimValue, lexeme sep parseStringConst, putValue' $ inBrackets sep (parseValue sep `sepBy` lexeme sep ","), lexeme sep $ "empty(" *> parseEmpty <* ")" ] where putValue' :: PutValue v => Parsec Void T.Text v -> Parsec Void T.Text Value putValue' p = do o <- getOffset x <- p case putValue x of Nothing -> parseError . FancyError o . S.singleton $ ErrorFail "array is irregular or has elements of multiple types." Just v -> pure v futhark-data-1.1.0.1/src/Futhark/Data/Reader.hs0000644000000000000000000000374707346545000017231 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} {-# LANGUAGE Trustworthy #-} -- | The value reader can handle a delightful mix of binary and -- textual input. It is the most general way of reading values, but -- it is less efficient than using the 'Get' instance if you know that -- the data will be in the binary format. module Futhark.Data.Reader ( readValues, ) where import Control.Monad import Data.Binary import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char (isPrint, isSpace) import qualified Data.Text as T import Futhark.Data import Futhark.Data.Parser import qualified Text.Megaparsec as MP import qualified Text.Megaparsec.Char as MP dropRestOfLine, dropSpaces :: LBS.ByteString -> LBS.ByteString dropRestOfLine = LBS.drop 1 . LBS.dropWhile (/= '\n') dropSpaces t = case LBS.dropWhile isSpace t of t' | "--" `LBS.isPrefixOf` t' -> dropSpaces $ dropRestOfLine t' | otherwise -> t' readValue :: LBS.ByteString -> Maybe (Value, LBS.ByteString) readValue full_t | Right (t', _, v) <- decodeOrFail full_t = Just (v, dropSpaces t') -- Some nasty hackery where we take the ASCII prefix of the -- bytestring, turn it into a Text, run the value parser, and -- prepend the remnant back. | otherwise = do let (a, b) = LBS.span (\c -> isSpace c || isPrint c) full_t case MP.parse ((,) <$> parseValue space <*> (MP.stateInput <$> MP.getParserState)) "" (T.pack (LBS.unpack a)) of Right (v, a') -> Just (v, LBS.pack (T.unpack a') <> b) _ -> Nothing where space = MP.space *> MP.choice ["--" *> restOfLine *> space, pure ()] restOfLine = MP.takeWhileP Nothing (/= '\n') <* MP.choice [void MP.eol, MP.eof] -- | Parse Futhark values from the given bytestring. readValues :: LBS.ByteString -> Maybe [Value] readValues = readValues' . dropSpaces where readValues' t | LBS.null t = Just [] | otherwise = do (a, t') <- readValue t (a :) <$> readValues' t' futhark-data-1.1.0.1/tests/0000755000000000000000000000000007346545000013556 5ustar0000000000000000futhark-data-1.1.0.1/tests/Tests.hs0000644000000000000000000001171207346545000015216 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main (main) where import Control.Monad import Data.Binary (encode) import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Int import qualified Data.Text as T import qualified Data.Vector.Storable as SVec import Data.Word import Futhark.Data import Futhark.Data.Compare import Futhark.Data.Parser import Futhark.Data.Reader import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Text.Megaparsec import Text.Megaparsec.Char (space) -- A hack to get around the default Eq instance for values, which does -- not handle NaNs the way we need. newtype TestValue = TestValue {unTestValue :: Value} instance Eq TestValue where TestValue x == TestValue y = null $ compareValues (Tolerance 0) x y instance Show TestValue where show (TestValue x) = show x instance Arbitrary TestValue where arbitrary = TestValue <$> oneof [ mk I8Value, mk I16Value, mk I32Value, mk I64Value, mk U8Value, mk U16Value, mk U32Value, mk U64Value, mk BoolValue ] where mk f = do -- Careful not to create enormous arrays. shape <- listOf $ choose (0, 3) f (SVec.fromList shape) . SVec.fromList <$> replicateM (product shape) arbitrary scalar :: SVec.Storable a => (Vector Int -> Vector a -> Value) -> a -> Value scalar f x = f mempty (SVec.singleton x) readerTests :: TestTree readerTests = testGroup "Reader" [ test "1" [scalar I32Value 1], test "2i32" [scalar I32Value 2], test "3i64" [scalar I64Value 3], test "[1, 2, 3]" [I32Value (SVec.fromList [3]) (SVec.fromList [1, 2, 3])], test "2i32 [1, 2, 3]" [ scalar I32Value 2, I32Value (SVec.fromList [3]) (SVec.fromList [1, 2, 3]) ], test "[[1,-- comment\n 2], [3,4]]" [I32Value (SVec.fromList [2, 2]) (SVec.fromList [1, 2, 3, 4])], test "b\STX\SOH i32\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\154\238\179u" [I32Value (SVec.fromList [1]) (SVec.fromList [1974726298])], test "0.9597767951851629f64\nb\STX\SOH i32\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\DC1\ETX\NUL\NUL2" [ scalar F64Value 0.9597767951851629, I32Value (SVec.fromList [1]) (SVec.fromList [785]), scalar I32Value 2 ], testProperty "read random binary data" $ \v -> (map TestValue <$> readValues (encode $ unTestValue v)) == Just [v], testProperty "read random text data" $ \v -> (map TestValue <$> readValues (LBS.pack $ T.unpack $ valueText $ unTestValue v)) == Just [v] ] where maxlen = 40 shorten s | length s < maxlen = s | otherwise = take (maxlen - 3) s <> "..." test s x = testCase ("Reading " <> shorten (show s)) $ readValues s @?= Just x parserTests :: TestTree parserTests = testGroup "Parser" [ test "1" $ scalar I32Value 1, negtest "_1", test "2i32" $ scalar I32Value 2, test "3i64" $ scalar I64Value 3, test "-2_3i32" $ scalar I32Value (-23), test "0b1_0_0_1" $ scalar I32Value 9, test "0x12_34" $ scalar I32Value 0x1234, test "3.1_4" $ scalar F64Value 3.14, test "1.0" $ scalar F64Value 1, negtest "_1.0", test "2f32" $ scalar F32Value 2, test "2f16" $ scalar F16Value 2, test "3.0f64" $ scalar F64Value 3.0, test "3.1f64" $ scalar F64Value 3.1, test "3.1_e-2f64" $ scalar F64Value 3.1e-2, test "f32.nan" $ scalar F32Value (0 / 0), test "f16.nan" $ scalar F16Value (0 / 0), test "f64.nan" $ scalar F64Value (0 / 0), test "f64.inf" $ scalar F64Value (1 / 0), test "-f64.inf" $ scalar F64Value (-1 / 0), test "true" $ scalar BoolValue True, test "false" $ scalar BoolValue False, test "\"foo\"" $ putValue1 ("foo" :: T.Text), test "\"\\\"foo\\\"\"" $ putValue1 ("\"foo\"" :: T.Text), negtest "tr_ue", testProperty "parse random data" $ \v -> (TestValue <$> parseMaybe (parseValue space) (valueText $ unTestValue v)) == Just v ] where test s x = testCase ("Parsing " <> show s) $ (TestValue <$> runParser (parseValue space <* eof) "" s) @?= Right (TestValue x) negtest s = testCase ("Parsing " <> show s) $ either (const Nothing) Just (TestValue <$> runParser (parseValue space <* eof) "" s) @?= Nothing getValueTests :: TestTree getValueTests = testGroup "GetValue" [ test (putValue1 (1 :: Int32)) (Nothing :: Maybe [Word8]), test (putValue1 (1 :: Int32)) (Just (1 :: Int32)) ] where test v expected = testCase (unwords ["getValue", v', "==", show expected]) $ getValue v @?= expected where v' = T.unpack (valueText v) allTests :: TestTree allTests = testGroup "" [readerTests, parserTests, getValueTests] main :: IO () main = defaultMain allTests