diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019-2020, Oleg Grenrus + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/Data/Structured.hs b/src/Data/Structured.hs new file mode 100644 --- /dev/null +++ b/src/Data/Structured.hs @@ -0,0 +1,61 @@ +-- | +-- +-- Copyright: (c) 2019-2020 Oleg Grenrus +-- +-- Structurally tag data. +-- +-- See @binary-tagged@ package taking use of this. +-- Useful when most 'Binary' instances are 'Generic' derived. +-- +-- Say you have a data type +-- +-- @ +-- data Record = Record +-- { _recordFields :: HM.HashMap Text (Integer, ByteString) +-- , _recordEnabled :: Bool +-- } +-- deriving (Eq, Show, Generic) +-- +-- instance Binary Record +-- instance 'Structured' Record +-- @ +-- +-- then you can serialise and deserialise @Record@ values with a structure tag by simply +-- +-- @ +-- 'structuredEncode' record :: LBS.ByteString +-- 'structuredDecode' lbs :: Either String Record +-- @ +-- +-- If structure of @Record@ changes in between, deserialisation will fail early. +-- +-- Technically, 'Structured' is not related to 'Binary', and may +-- be useful in other ways. +-- +module Data.Structured ( + -- * Structured class + Structured (structure), + structureHash, + structureBuilder, + genericStructure, + GStructured, + nominalStructure, + containerStructure, + -- * Structure type + Structure (..), + TypeName, + ConstructorName, + TypeVersion, + SopStructure, + hashStructure, + typeVersion, + typeName, + -- * MD5 + MD5, + showMD5, + md5, + md5FromInteger, + ) where + +import Data.Structured.Internal +import Data.Structured.MD5 diff --git a/src/Data/Structured/Internal.hs b/src/Data/Structured/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Structured/Internal.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 711 +{-# LANGUAGE PatternSynonyms #-} +#endif +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TypeInType #-} +#endif +{-# OPTIONS_HADDOCK not-home #-} + +module Data.Structured.Internal where + +import Data.Structured.MD5 + +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List.NonEmpty (NonEmpty) +import Data.Proxy (Proxy (..)) +import Data.Ratio (Ratio) +import Data.Tagged (Tagged (..), untag) +import Data.Word (Word, Word16, Word32, Word64, Word8) +import Numeric.Natural (Natural) + +import qualified Control.Monad.Trans.State.Strict as State + +import GHC.Generics + +import qualified Data.Aeson as Aeson +import qualified Data.Array.IArray as Array +import qualified Data.Array.Unboxed as Array +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Builder as Builder +import qualified Data.ByteString.Short as SBS +import qualified Data.Fixed as Fixed +import qualified Data.HashMap.Lazy as HML +import qualified Data.HashSet as HS +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as Map +import qualified Data.Monoid as Monoid +import qualified Data.Scientific as Sci +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Time.Compat as Time +import qualified Data.UUID.Types as UUID +import qualified Data.Vector as V +import qualified Data.Vector.Storable as SV +import qualified Data.Vector.Unboxed as UV +import qualified Data.Version as Version + +#if __GLASGOW_HASKELL__ >= 800 +import Data.Kind (Type) +#else +#define Type * +#endif + +import Data.Typeable (TypeRep, Typeable, typeRep) + +import Data.Monoid (mconcat) + +import qualified Data.Foldable +import qualified Data.Semigroup + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure) +import Data.Traversable (traverse) +#endif + +#if !MIN_VERSION_base(4,7,0) +import Data.Typeable (Typeable1, typeOf1) +#endif + + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +type TypeName = String +type ConstructorName = String + +-- | A sematic version of a data type. Usually 0. +type TypeVersion = Word32 + +-- | Structure of a datatype. +-- +-- It can be infinite, as far as 'TypeRep's involved are finite. +-- (e.g. polymorphic recursion might cause troubles). +-- +data Structure + = Nominal !TypeRep !TypeVersion TypeName [Structure] -- ^ nominal, yet can be parametrised by other structures. + | Newtype !TypeRep !TypeVersion TypeName Structure -- ^ a newtype wrapper + | Structure !TypeRep !TypeVersion TypeName SopStructure -- ^ sum-of-products structure + deriving (Eq, Ord, Show, Generic) + +type SopStructure = [(ConstructorName, [Structure])] + +-- | A MD5 hash digest of 'Structure'. +hashStructure :: Structure -> MD5 +hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder + +-- | A van-Laarhoven lens into 'TypeVersion' of 'Structure' +-- +-- @ +-- 'typeVersion' :: Lens' 'Structure' 'TypeVersion' +-- @ +typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure +typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v) +typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v) +typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v) + +-- | A van-Laarhoven lens into 'TypeName' of 'Structure' +-- +-- @ +-- 'typeName' :: Lens' 'Structure' 'TypeName' +-- @ +typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure +typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n) +typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n) +typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n) + +------------------------------------------------------------------------------- +-- Builder +------------------------------------------------------------------------------- + +-- | Flatten 'Structure' into something we can calculate hash of. +-- +-- As 'Structure' can be potentially infinite. For mutually recursive types, +-- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred +-- another time. +structureBuilder :: Structure -> Builder.Builder +structureBuilder s0 = State.evalState (go s0) Map.empty where + go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder + go (Nominal t v n s) = withTypeRep t $ do + s' <- traverse go s + return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s' + + go (Newtype t v n s) = withTypeRep t $ do + s' <- go s + return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s'] + + go (Structure t v n s) = withTypeRep t $ do + s' <- goSop s + return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s'] + + withTypeRep t k = do + acc <- State.get + case insert t acc of + Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ] + Just acc' -> do + State.put acc' + k + + goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder + goSop sop = do + parts <- traverse part sop + return $ mconcat parts + + part (cn, s) = do + s' <- traverse go s + return $ Data.Monoid.mconcat [ Builder.stringUtf8 cn, mconcat s' ] + + insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep)) + insert tr m = case Map.lookup trShown m of + Nothing -> inserted + Just ne | tr `Data.Foldable.elem` ne -> Nothing + | otherwise -> inserted + where + inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m) + trShown = show tr + +------------------------------------------------------------------------------- +-- Classes +------------------------------------------------------------------------------- + +-- | Class of types with a known 'Structure'. +-- +-- For regular data types 'Structured' can be derived generically. +-- +-- @ +-- data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving ('Generic') +-- instance 'Structured' Record +-- @ +-- +-- @since 3.2.0.0 +-- +class Typeable a => Structured a where + structure :: Proxy a -> Structure + default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure + structure = genericStructure + + -- This member is hidden. It's there to precalc + structureHash' :: Tagged a MD5 + structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a))) + +-- | Semantically @'hashStructure' . 'structure'@. +structureHash :: forall a. Structured a => Proxy a -> MD5 +structureHash _ = untag (structureHash' :: Tagged a MD5) + +------------------------------------------------------------------------------- +-- Smart constructors +------------------------------------------------------------------------------- + +-- | Use 'Typeable' to infer name +nominalStructure :: Typeable a => Proxy a -> Structure +nominalStructure p = Nominal tr 0 (show tr) [] where + tr = typeRep p + +#if MIN_VERSION_base(4,7,0) +containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure +containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) + [ structure (Proxy :: Proxy a) + ] + where + fTypeRep = typeRep (Proxy :: Proxy f) + faTypeRep = typeRep (Proxy :: Proxy (f a)) + +#else +containerStructure :: forall f a. (Typeable1 f, Structured a) => Proxy (f a) -> Structure +containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) + [ structure (Proxy :: Proxy a) + ] + where + fTypeRep = typeOf1 (undefined :: f ()) + faTypeRep = typeRep (Proxy :: Proxy (f a)) +#endif + +------------------------------------------------------------------------------- +-- Generic +------------------------------------------------------------------------------- + +-- | Derive 'structure' genrically. +genericStructure :: forall a. (Typeable a, Generic a, GStructured (Rep a)) => Proxy a -> Structure +genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (Rep a)) 0 + +-- | Used to implement 'genericStructure'. +class GStructured (f :: Type -> Type) where + gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure + +instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where + gstructured tr _ v = case sop of +#if MIN_VERSION_base(4,7,0) + [(_, [s])] | isNewtype p -> Newtype tr v name s +#endif + _ -> Structure tr v name sop + where + p = undefined :: M1 i c f () + name = datatypeName p + sop = gstructuredSum (Proxy :: Proxy f) [] + +class GStructuredSum (f :: Type -> Type) where + gstructuredSum :: Proxy f -> SopStructure -> SopStructure + +instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where + gstructuredSum _ xs = (name, prod) : xs + where + name = conName (undefined :: M1 i c f ()) + prod = gstructuredProd (Proxy :: Proxy f) [] + +instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where + gstructuredSum _ xs + = gstructuredSum (Proxy :: Proxy f) + $ gstructuredSum (Proxy :: Proxy g) xs + +instance GStructuredSum V1 where + gstructuredSum _ = id + +class GStructuredProd (f :: Type -> Type) where + gstructuredProd :: Proxy f -> [Structure] -> [Structure] + +instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where + gstructuredProd _ = gstructuredProd (Proxy :: Proxy f) + +instance Structured c => GStructuredProd (K1 i c) where + gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs + +instance GStructuredProd U1 where + gstructuredProd _ = id + +instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where + gstructuredProd _ xs + = gstructuredProd (Proxy :: Proxy f) + $ gstructuredProd (Proxy :: Proxy g) xs + +------------------------------------------------------------------------------- +-- base +------------------------------------------------------------------------------- + +instance Structured () +instance Structured Bool +instance Structured Ordering + +instance Structured Char where structure = nominalStructure + +instance (Structured a, Structured b) => Structured (a -> b) where + structure _ = Nominal + (typeRep (Proxy :: Proxy (a -> b))) + 0 + ("(->)") + [structure (Proxy :: Proxy a), structure (Proxy :: Proxy b)] + +instance Structured a => Structured (Maybe a) +instance (Structured a, Structured b) => Structured (Either a b) +instance Structured a => Structured (Ratio a) where structure = containerStructure +instance Structured a => Structured [a] where structure = containerStructure +instance Structured a => Structured (NonEmpty a) where structure = containerStructure + +instance (Structured a1, Structured a2) => Structured (a1, a2) +instance (Structured a1, Structured a2, Structured a3) => Structured (a1, a2, a3) +instance (Structured a1, Structured a2, Structured a3, Structured a4) => Structured (a1, a2, a3, a4) +instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5) => Structured (a1, a2, a3, a4, a5) +instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6) => Structured (a1, a2, a3, a4, a5, a6) +instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6, Structured a7) => Structured (a1, a2, a3, a4, a5, a6, a7) + +------------------------------------------------------------------------------- +-- base: numbers +------------------------------------------------------------------------------- + +instance Structured Int where structure = nominalStructure +instance Structured Integer where structure = nominalStructure + +instance Structured Data.Word.Word where structure = nominalStructure + +instance Structured Int8 where structure = nominalStructure +instance Structured Int16 where structure = nominalStructure +instance Structured Int32 where structure = nominalStructure +instance Structured Int64 where structure = nominalStructure + +instance Structured Word8 where structure = nominalStructure +instance Structured Word16 where structure = nominalStructure +instance Structured Word32 where structure = nominalStructure +instance Structured Word64 where structure = nominalStructure + +instance Structured Float where structure = nominalStructure +instance Structured Double where structure = nominalStructure + +#if __GLASGOW_HASKELL__ >=810 +instance (Typeable k, Typeable (a :: k), Fixed.HasResolution a) => Structured (Fixed.Fixed a) where +#else +instance (Typeable a, Fixed.HasResolution a) => Structured (Fixed.Fixed a) where +#endif + structure _ = Nominal + (typeRep (Proxy :: Proxy (Fixed.Fixed a))) + 0 + ("Fixed " ++ show (Fixed.resolution (Proxy :: Proxy a))) + [] + +instance Structured Natural where structure = nominalStructure + +------------------------------------------------------------------------------- +-- semigroup +------------------------------------------------------------------------------- + +instance Structured a => Structured (Semigroup.Min a) +instance Structured a => Structured (Semigroup.Max a) +instance Structured a => Structured (Semigroup.First a) +instance Structured a => Structured (Semigroup.Last a) +instance Structured a => Structured (Semigroup.WrappedMonoid a) + +------------------------------------------------------------------------------- +-- monoid +------------------------------------------------------------------------------- + +instance Structured a => Structured (Monoid.First a) +instance Structured a => Structured (Monoid.Last a) +instance Structured a => Structured (Monoid.Sum a) +instance Structured a => Structured (Monoid.Product a) +instance Structured a => Structured (Monoid.Dual a) +instance Structured a => Structured (Monoid.Endo a) +instance Structured Monoid.All +instance Structured Monoid.Any + +------------------------------------------------------------------------------- +-- bytestring +------------------------------------------------------------------------------- + +instance Structured BS.ByteString where structure = nominalStructure +instance Structured LBS.ByteString where structure = nominalStructure +instance Structured SBS.ShortByteString where structure = nominalStructure + +------------------------------------------------------------------------------- +-- text +------------------------------------------------------------------------------- + +instance Structured T.Text where structure = nominalStructure +instance Structured LT.Text where structure = nominalStructure + +------------------------------------------------------------------------------- +-- containers +------------------------------------------------------------------------------- + +instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ] +instance (Structured k) => Structured (Set.Set k) where structure = containerStructure +instance (Structured v) => Structured (IM.IntMap v) where structure = containerStructure +instance Structured IS.IntSet where structure = nominalStructure +instance (Structured v) => Structured (Seq.Seq v) where structure = containerStructure + +------------------------------------------------------------------------------- +-- time +------------------------------------------------------------------------------- + +instance Structured Time.UTCTime where structure = nominalStructure +instance Structured Time.DiffTime where structure = nominalStructure +instance Structured Time.UniversalTime where structure = nominalStructure +instance Structured Time.NominalDiffTime where structure = nominalStructure +instance Structured Time.Day where structure = nominalStructure +instance Structured Time.TimeZone where structure = nominalStructure +instance Structured Time.TimeOfDay where structure = nominalStructure +instance Structured Time.LocalTime where structure = nominalStructure +instance Structured Time.DayOfWeek where structure = nominalStructure + +------------------------------------------------------------------------------- +-- array +------------------------------------------------------------------------------- + +instance (Structured i, Structured e) => Structured (Array.Array i e) where + structure _ = Nominal (typeRep (Proxy :: Proxy (Array.Array i e))) 0 "Array" [ structure (Proxy :: Proxy i), structure (Proxy :: Proxy e) ] + +instance (Structured i, Structured e) => Structured (Array.UArray i e) where + structure _ = Nominal (typeRep (Proxy :: Proxy (Array.UArray i e))) 0 "UArray" [ structure (Proxy :: Proxy i), structure (Proxy :: Proxy e) ] + +------------------------------------------------------------------------------- +-- aeson +------------------------------------------------------------------------------- + +instance Structured Aeson.Value + +------------------------------------------------------------------------------- +-- unordered-containers +------------------------------------------------------------------------------- + +instance (Structured k, Structured v) => Structured (HML.HashMap k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (HML.HashMap v))) 0 "HashMap" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ] +instance (Structured k) => Structured (HS.HashSet k) where structure = containerStructure + +------------------------------------------------------------------------------- +-- vector +------------------------------------------------------------------------------- + +instance (Structured v) => Structured (V.Vector v) where structure = containerStructure +instance (Structured v) => Structured (SV.Vector v) where structure = containerStructure +instance (Structured v) => Structured (UV.Vector v) where structure = containerStructure + +------------------------------------------------------------------------------- +-- scientific +------------------------------------------------------------------------------- + +instance Structured Sci.Scientific where structure = nominalStructure + +------------------------------------------------------------------------------- +-- uuid-types +------------------------------------------------------------------------------- + +instance Structured UUID.UUID where structure = nominalStructure + +------------------------------------------------------------------------------- +-- base: version +------------------------------------------------------------------------------- + +-- Generic Version is since base-4.9.0.0 +instance Structured Version.Version where structure = nominalStructure + +------------------------------------------------------------------------------- +-- tagged +------------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 800 +instance (Typeable k, Typeable (b :: k), Structured a) => Structured (Tagged b a) +#else +instance (Typeable (b :: Type), Structured a) => Structured (Tagged b a) +#endif +-- Proxy isn't Typeable in base-4.8 / base + +-- #if __GLASGOW_HASKELL__ >= 800 +-- instance (Typeable k, Typeable (a :: k)) => Structured (Proxy a) +-- #else +-- instance (Typeable a) => Structured (Proxy a) where +-- structure p = Structure (typeRep p) 0 "Proxy" [("Proxy",[])] +-- #endif diff --git a/src/Data/Structured/MD5.hs b/src/Data/Structured/MD5.hs new file mode 100644 --- /dev/null +++ b/src/Data/Structured/MD5.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE Trustworthy #-} +module Data.Structured.MD5 ( + MD5, + showMD5, + md5, + md5FromInteger, + ) where + +import Data.Bits (complement, shiftR, (.&.)) +import Foreign.Ptr (castPtr) +import GHC.Fingerprint (Fingerprint (..), fingerprintData) +import Numeric (showHex) +import System.IO.Unsafe (unsafeDupablePerformIO) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +type MD5 = Fingerprint + +-- | Show 'MD5' in human readable form +-- +-- >>> showMD5 (Fingerprint 123 456) +-- "000000000000007b00000000000001c8" +-- +-- >>> showMD5 $ md5 $ BS.pack [0..127] +-- "37eff01866ba3f538421b30b7cbefcac" +-- +-- @since 3.2.0.0 +showMD5 :: MD5 -> String +showMD5 (Fingerprint a b) = pad a' ++ pad b' where + a' = showHex a "" + b' = showHex b "" + pad s = replicate (16 - length s) '0' ++ s + +-- | @since 3.2.0.0 +md5 :: BS.ByteString -> MD5 +md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + fingerprintData (castPtr ptr) len + +-- | +-- +-- >>> showMD5 $ md5FromInteger 0x37eff01866ba3f538421b30b7cbefcac +-- "37eff01866ba3f538421b30b7cbefcac" +-- +-- Note: the input is truncated: +-- +-- >>> showMD5 $ md5FromInteger 0x1230000037eff01866ba3f538421b30b7cbefcac +-- "37eff01866ba3f538421b30b7cbefcac" +-- +-- Yet, negative numbers are not a problem... +-- +-- >>> showMD5 $ md5FromInteger (-1) +-- "ffffffffffffffffffffffffffffffff" +-- +-- @since 3.4.0.0 +md5FromInteger :: Integer -> MD5 +md5FromInteger i = Fingerprint hi lo where + mask = complement 0 + lo = mask .&. fromInteger i + hi = mask .&. fromInteger (i `shiftR` 64) diff --git a/structured.cabal b/structured.cabal new file mode 100644 --- /dev/null +++ b/structured.cabal @@ -0,0 +1,67 @@ +cabal-version: 2.2 +name: structured +version: 0.1 +synopsis: Structure (hash) of your data types +category: Data +description: + Calculate the hash of a data structure. + It can be used as a magic number for the serialization formats. + See + for a @binary@ bindings. + +bug-reports: https://github.com/phadej/binary-tagged/issues +author: Oleg Grenrus +maintainer: Oleg Grenrus +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +tested-with: + GHC ==7.8.4 + || ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.3 + || ==8.10.1 + +source-repository head + type: git + location: https://github.com/phadej/binary-tagged + subdir: structured + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Data.Structured + exposed-modules: Data.Structured.Internal + other-modules: Data.Structured.MD5 + + -- Libraries bundled with GHC + build-depends: + array >=0.5.0.0 && <0.6 + , base >=4.7.0.2 && <4.15 + , binary >=0.7.1.0 && <0.10 + , bytestring >=0.10.4.0 && <0.11 + , containers >=0.5.5.1 && <0.7 + , text >=1.2.3.0 && <1.3 + , time-compat >=1.9.2.2 && <1.10 + , transformers >=0.3.0.0 && <0.6 + + -- other dependencies + build-depends: + aeson >=0.8 && <1.5 + , base16-bytestring >=0.1.1.6 && <0.2 + , hashable >=1.2 && <1.4 + , scientific >=0.3 && <0.4 + , tagged >=0.7 && <0.9 + , unordered-containers >=0.2 && <0.3 + , uuid-types >=1.0.3 && <1.1 + , vector >=0.10 && <0.13 + + if !impl(ghc >=8.0) + build-depends: semigroups >=0.18.5 && <0.20 + + if !impl(ghc >=7.10) + build-depends: nats >=1.1.2 && <1.2