futhark-data (empty) → 1.0.0.0
raw patch · 8 files changed
+1045/−0 lines, 8 filesdep +QuickCheckdep +basedep +binary
Dependencies added: QuickCheck, base, binary, bytestring, bytestring-to-vector, containers, futhark-data, megaparsec, mtl, tasty, tasty-hunit, tasty-quickcheck, text, vector, vector-binary-instances
Files
- CHANGELOG.md +5/−0
- LICENSE +17/−0
- futhark-data.cabal +59/−0
- src/Futhark/Data.hs +449/−0
- src/Futhark/Data/Compare.hs +162/−0
- src/Futhark/Data/Parser.hs +165/−0
- src/Futhark/Data/Reader.hs +59/−0
- tests/Tests.hs +129/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for futhark-data++## 1.0.0.0 -- 2021-06-08++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,17 @@+ISC 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.cabal view
@@ -0,0 +1,59 @@+cabal-version: 2.4+name: futhark-data+version: 1.0.0.0+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: Data+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+ , megaparsec >=9.0.0+ , mtl >=2.2.1+ , 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
+ src/Futhark/Data.hs view
@@ -0,0 +1,449 @@+{-# 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 (..),+ 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)++-- | 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)+ | 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 (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+ " 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+ 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+ 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 | 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 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 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 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 (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+ 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 = mapM getValue . valueElems++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 . I8Value mempty . SVec.singleton++instance PutValue Int16 where+ putValue = Just . I16Value mempty . SVec.singleton++instance PutValue Int32 where+ putValue = Just . I32Value mempty . SVec.singleton++instance PutValue Int64 where+ putValue = Just . I64Value mempty . SVec.singleton++instance PutValue Word8 where+ putValue = Just . U8Value mempty . SVec.singleton++instance PutValue Word16 where+ putValue = Just . U16Value mempty . SVec.singleton++instance PutValue Word32 where+ putValue = Just . U32Value mempty . SVec.singleton++instance PutValue Word64 where+ putValue = Just . U64Value mempty . SVec.singleton++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)+ 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 (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)]
+ src/Futhark/Data/Compare.hs view
@@ -0,0 +1,162 @@+{-# 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+ (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 = undefined+ {-# INLINE compareGen #-}+ {-# INLINE compareNum #-}+ {-# INLINE compareFloat #-}+ {-# INLINE compareFloatElement #-}+ {-# INLINE compareElement #-}+ compareNum :: (SVec.Storable a, Eq a) => SVec.Vector a -> SVec.Vector a -> [Mismatch]+ compareNum = compareGen compareElement+ compareFloat :: (SVec.Storable a, RealFloat 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 :: 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 :: 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
+ src/Futhark/Data/Parser.hs view
@@ -0,0 +1,165 @@+{-# 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.Except+import Data.Functor+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.Lexer+ ( binary,+ decimal,+ float,+ hexadecimal,+ signed,+ )++-- | 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,+ "f32" $> F32,+ "f64" $> F64,+ "bool" $> Bool+ ]++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 $ "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)++parseFloatConst :: Parsec Void T.Text Value+parseFloatConst =+ choice+ [ "f32.nan" $> scalar F32Value (0 / 0),+ "f64.nan" $> scalar F64Value (0 / 0),+ "f32.inf" $> scalar F32Value (1 / 0),+ "f64.inf" $> scalar F64Value (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 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)+ ]++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+ 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,+ 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
+ src/Futhark/Data/Reader.hs view
@@ -0,0 +1,59 @@+{-# 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'
+ tests/Tests.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Monad+import Data.Binary (encode)+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.Text as T+import qualified Data.Vector.Storable as SVec+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,+ test "2i32" $ scalar I32Value 2,+ test "3i64" $ scalar I64Value 3,+ test "1.0" $ scalar F64Value 1,+ test "2f32" $ scalar F32Value 2,+ test "3.1f64" $ scalar F64Value 3.1,+ test "f32.nan" $ scalar F32Value (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,+ 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)++allTests :: TestTree+allTests =+ testGroup "" [readerTests, parserTests]++main :: IO ()+main = defaultMain allTests