futhark-data 1.1.0.1 → 1.1.1.0

raw patch · 7 files changed

+85/−63 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• futhark-data.cabal +1/−1
• src/Futhark/Data.hs +18/−5
• src/Futhark/Data/Compare.hs +39/−39
• src/Futhark/Data/Parser.hs +8/−7
• src/Futhark/Data/Reader.hs +10/−10
• tests/Tests.hs +2/−1

@@ -1,5 +1,12 @@ # Revision history for futhark-data +## 1.1.1.0++* Trailing commas are now allowed in array notation.++* The `PutValue` and `PutValue1` classes now have instances for+  `Data.ByteString.Lazy.Char8.ByteString`.+ ## 1.1.0.1 -- 2023-03-21  * Minor fix for GHC 9.6 changes.

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               futhark-data-version:            1.1.0.1+version:            1.1.1.0 synopsis:           An implementation of the Futhark data format.  description: The Futhark compiler and its tools uses a simple external

@@ -107,9 +107,11 @@     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+      fail $+        "Expecting binary format version 1; found version: " ++ show version     unless (rank >= 0) $-      fail $ "Rank must be non-negative, but is: " ++ show rank+      fail $+        "Rank must be non-negative, but is: " ++ show rank      type_f <- getLazyByteString 4 @@ -131,7 +133,12 @@       " 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+      "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@@ -143,7 +150,7 @@       int8ToBool = (/= 0)  putBinaryValue ::-  SVec.Storable a =>+  (SVec.Storable a) =>   String ->   Vector Int ->   Vector a ->@@ -338,7 +345,7 @@ class GetValue t where   getValue :: Value -> Maybe t -instance GetValue t => GetValue [t] where+instance (GetValue t) => GetValue [t] where   getValue v     | null $ valueShape v = Nothing     | otherwise = mapM getValue $ valueElems v@@ -468,6 +475,9 @@     where       size = SVec.fromList [fromIntegral (BS.length bs)] +instance PutValue LBS.ByteString where+  putValue = putValue . LBS.toStrict+ -- | Like 'PutValue', but only for scalars and a few other simple -- things that cannot fail. class PutValue1 t where@@ -504,3 +514,6 @@   putValue1 bs = U8Value size $ byteStringToVector bs     where       size = SVec.fromList [fromIntegral (BS.length bs)]++instance PutValue1 LBS.ByteString where+  putValue1 = putValue1 . LBS.toStrict

@@ -26,7 +26,7 @@   | TypeMismatch Int T.Text T.Text   | ValueCountMismatch Int Int -showText :: Show a => a -> T.Text+showText :: (Show a) => a -> T.Text showText = T.pack . show  -- | A human-readable description of how two values are not the same.@@ -52,7 +52,7 @@ newtype Tolerance = Tolerance Double   deriving (Eq, Ord, Show) -toleranceFloat :: RealFloat a => Tolerance -> a+toleranceFloat :: (RealFloat a) => Tolerance -> a toleranceFloat (Tolerance x) = fromRational $ toRational x  -- | Compare two Futhark values for equality.@@ -81,38 +81,38 @@ 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)]+      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)]+      [ArrayShapeMismatch i (valueShape got_v) (valueShape expected_v)]   where     unflatten = unflattenIndex (valueShape got_v)-    value :: Show a => a -> T.Text+    value :: (Show a) => a -> T.Text     value = T.pack . show     {-# INLINE compareGen #-}     {-# INLINE compareNum #-}@@ -128,13 +128,13 @@       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)+                case cmp j (got SVec.! j) (expected SVec.! j) of+                  Just mismatch ->+                    check (mismatch : acc) (j + 1)+                  Nothing ->+                    check acc (j + 1)             | otherwise =-              acc+                acc        in reverse $ check [] 0      compareElement :: (Show a, Eq a) => Int -> a -> a -> Maybe Mismatch@@ -146,11 +146,11 @@     compareFloatElement abstol j got expected       | isNaN got,         isNaN expected =-        Nothing+          Nothing       | isInfinite got,         isInfinite expected,         signum got == signum expected =-        Nothing+          Nothing       | abs (got - expected) <= abstol = Nothing       | otherwise = Just $ PrimValueMismatch i (unflatten j) (value got) (value expected) 

@@ -59,7 +59,7 @@     pOrUnderscore c = p c || c == '_'  -- Adapted from megaparsec.-decimal :: Num a => Parsec Void T.Text a+decimal :: (Num a) => Parsec Void T.Text a decimal =   mkNum <$> allowUnderscores "digit" isDigit   where@@ -67,7 +67,7 @@     step a c = a * 10 + fromIntegral (digitToInt c)  -- Adapted from megaparsec.-binary :: Num a => Parsec Void T.Text a+binary :: (Num a) => Parsec Void T.Text a binary =   mkNum <$> allowUnderscores "binary digit" isBinDigit   where@@ -76,7 +76,7 @@     isBinDigit x = x == '0' || x == '1'  -- Adapted from megaparsec.-hexadecimal :: Num a => Parsec Void T.Text a+hexadecimal :: (Num a) => Parsec Void T.Text a hexadecimal =   mkNum <$> allowUnderscores "hexadecimal digit" isHexDigit   where@@ -92,7 +92,7 @@         decimal       ] -scalar :: SVec.Storable a => (Vector Int -> Vector a -> Value) -> a -> Value+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@@ -115,7 +115,7 @@       suffix $> scalar mk (fromInteger x)  -- Adapted from megaparsec.-float :: RealFloat a => Parsec Void T.Text a+float :: (RealFloat a) => Parsec Void T.Text a float = do   c' <- decimal   Sci.toRealFloat@@ -220,11 +220,12 @@   choice     [ lexeme sep parsePrimValue,       lexeme sep parseStringConst,-      putValue' $ inBrackets sep (parseValue sep `sepBy` lexeme sep ","),+      putValue' . inBrackets sep $+        (parseValue sep `sepEndBy` lexeme sep ","),       lexeme sep $ "empty(" *> parseEmpty <* ")"     ]   where-    putValue' :: PutValue v => Parsec Void T.Text v -> Parsec Void T.Text Value+    putValue' :: (PutValue v) => Parsec Void T.Text v -> Parsec Void T.Text Value     putValue' p = do       o <- getOffset       x <- p

@@ -32,18 +32,18 @@ readValue :: LBS.ByteString -> Maybe (Value, LBS.ByteString) readValue full_t   | Right (t', _, v) <- decodeOrFail full_t =-    Just (v, dropSpaces 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+      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]@@ -55,5 +55,5 @@     readValues' t       | LBS.null t = Just []       | otherwise = do-        (a, t') <- readValue t-        (a :) <$> readValues' t'+          (a, t') <- readValue t+          (a :) <$> readValues' t'

@@ -50,7 +50,7 @@         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 :: (SVec.Storable a) => (Vector Int -> Vector a -> Value) -> a -> Value scalar f x = f mempty (SVec.singleton x)  readerTests :: TestTree@@ -127,6 +127,7 @@       test "\"foo\"" $ putValue1 ("foo" :: T.Text),       test "\"\\\"foo\\\"\"" $ putValue1 ("\"foo\"" :: T.Text),       negtest "tr_ue",+      test "[1,2,3,]" $ I32Value (SVec.fromList [3]) (SVec.fromList [1, 2, 3]),       testProperty "parse random data" $         \v ->           (TestValue <$> parseMaybe (parseValue space) (valueText $ unTestValue v))